summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSalvatore Bonaccorso <carnil@debian.org>2018-12-12 22:18:57 +0100
committerSalvatore Bonaccorso <carnil@debian.org>2018-12-12 22:18:57 +0100
commitd123189449465a21b91fb60337a97adf75fd8dd5 (patch)
tree332de061b4f6e41b47e70dc15dcbc54c859dc863
Import libio-prompter-perl_0.004015.orig.tar.gz
[dgit import orig libio-prompter-perl_0.004015.orig.tar.gz]
Diffstat
-rw-r--r--Changes191
-rw-r--r--MANIFEST45
-rw-r--r--META.json42
-rw-r--r--META.yml23
-rw-r--r--Makefile.PL18
-rw-r--r--README51
-rw-r--r--lib/IO/Prompter.pm3596
-rw-r--r--t/00.load.t10
-rw-r--r--t/argv.t26
-rw-r--r--t/autoexport.t27
-rw-r--r--t/bundled.t15
-rw-r--r--t/default.t42
-rw-r--r--t/errors.t84
-rw-r--r--t/fail.t37
-rw-r--r--t/fake.t35
-rw-r--r--t/fake_no_term_readkey.t36
-rw-r--r--t/filehandles.t36
-rw-r--r--t/guarantee.t47
-rw-r--r--t/integer.t51
-rw-r--r--t/interactive.t37
-rw-r--r--t/interactive_echo.t52
-rw-r--r--t/interactive_no_term_readkey.t40
-rw-r--r--t/interactive_out.t34
-rw-r--r--t/interactive_return.t36
-rw-r--r--t/interactive_wipe.t36
-rw-r--r--t/interactive_wipe_wipefirst.t37
-rw-r--r--t/interactive_wipefirst.t37
-rw-r--r--t/keyletters.t47
-rw-r--r--t/lexical_options.t64
-rw-r--r--t/line.t28
-rw-r--r--t/list_context.t54
-rw-r--r--t/must.t57
-rw-r--r--t/no_term_readkey.t29
-rw-r--r--t/number.t30
-rw-r--r--t/orlast.t20
-rw-r--r--t/pod-coverage.t6
-rw-r--r--t/pod.t6
-rw-r--r--t/simple.t28
-rw-r--r--t/single.t36
-rw-r--r--t/styles.t83
-rw-r--r--t/timeout.t74
-rw-r--r--t/timeout_no_term_readkey.t77
-rw-r--r--t/verbatim.t34
-rw-r--r--t/yesno.t94
-rw-r--r--t/zen.t29
45 files changed, 5517 insertions, 0 deletions
diff --git a/Changes b/Changes
new file mode 100644
index 0000000..da2fd3e
--- /dev/null
+++ b/Changes
@@ -0,0 +1,191 @@
+Revision history for IO-Prompter
+
+0.0.1 Fri May 1 17:34:17 2009
+ Initial release.
+
+
+0.001001 Tue Jun 22 05:39:09 2010
+
+ * More documentation
+
+ * Fixed README
+
+ * Tweaked Makefile.PL and Build.PL
+
+ * Fixed history completion (removed prefix)
+
+ * Added 'dirnames' as a completion option
+
+ * Allowed use of -number or -integer to specify numerically indexed -menu
+
+ * Made $SIG{INT} handling transparent
+
+ * Made constraints apply to -default value
+ (and issue a warning if they aren't satisfied)
+
+ * Added -DEFAULT option to override constraint checking
+
+ * Added -keyletters option to extract guarantees and defaults
+ from the prompt
+
+
+0.002000 Tue Apr 10 17:25:54 2012
+
+ * Fixed selection of menu items specified by non-single character
+ (Thanks Chris!)
+
+ * Tweaked varname in docs (thanks Salvatore)
+
+ * Other doc fixes
+
+ * Made default values echo when selected
+
+ * Fixed -default value handling on -menu prompts
+ (disabled constraint-checking on that case)
+
+ * Fixed -keyletters example (-guarantee regex was wrong)
+
+ * Allowed -key and -keys as abbreviations for -keyletters
+
+ * Added -style and -echostyle features
+
+ * Added: use IO::Prompter -argv
+
+ * Improved -argv prompting
+
+0.003000 Thu Jun 14 21:34:33 EST 2012
+
+ * Added lexically scoped automatic options
+ (e.g. use IO::Prompter [-yesno, -single])
+
+ * Fixes for -argv mode (especially filename completion)
+
+ * Added -yesno => $count option
+
+ * BACKWARDS INCOMPATIBLE CHANGE: Changed behaviour of prompt() in
+ list contexts: now returns empty list on failure.
+ Use C<scalar prompt @args> to get old behaviour.
+
+
+0.003001 Tue Jul 3 17:54:40 2012
+
+ * Documented -echo=>'yea/nay' special case
+
+ * Fixed erroneous error message when completing with 'dirnames'
+ (thanks Matthias!)
+
+
+0.004000 Sat Sep 22 14:30:13 2012
+
+ * Added ^A, ^B, ^E, ^F for in-line editing
+
+
+0.004001 Sun Sep 23 21:18:33 2012
+
+ * Fixed nasty bug that prevented echoing most upper-case input
+
+
+0.004002 Mon Sep 24 11:39:24 2012
+
+ * Fixed induced error in input faking
+
+
+
+0.004003 Wed Jan 16 16:24:09 2013
+
+ * Patched history mechanism to allow non-recording of input history
+ (thanks Brian!)
+
+
+0.004004 Sun Jan 27 09:05:25 2013
+
+ * Patched missing validity check for non-ReadKey input under -menu
+ (thanks Kalyan Raj!)
+
+
+0.004005 Wed Mar 6 09:19:56 2013
+
+ * Disabled interactive testing on Windows platforms
+ (thanks Brian and Lady Aleena)
+
+
+0.004006 Thu Aug 29 10:28:48 2013
+
+ * Better handling of input EOL under Windows (thanks Bas)
+
+ * Workaround for Term::ReadKey bug under Windows (thanks Bas)
+
+
+0.004007 Fri Aug 30 07:25:33 2013
+
+ * Reworked workaround for Term::ReadKey timeout bug under Windows
+ (thanks again, Bas)
+
+
+0.004008 Mon Sep 30 14:36:57 2013
+
+ * Further improvements under 5.18, especially for Windows
+ (thanks, Bas)
+
+ * Attempted to mollify cpanm by moving $VERSION declaration
+
+
+0.004009 Wed Oct 2 21:55:06 2013
+
+ * Further improvements under 5.18
+ (thanks, Gareth)
+
+
+
+0.004010 Thu Oct 3 18:17:48 2013
+
+ * Still further improvements under Windows
+ (thanks, Gareth)
+
+ * Fixed spurious ERASEs when deleting "past" start of input
+ (thanks, Gareth)
+
+
+0.004011 Fri Jul 25 17:03:42 2014
+
+ * Added 'normal', 'default', 'standard', etc. to colour translation
+
+ * Added <ESC><ESC> at start of faked input to defer next fake and insert real input
+ (i.e. like <ESC>, but doesn't throw away the line that was scheduled next)
+
+
+0.004012 Wed Feb 4 09:46:17 2015
+
+ * Added -void option to silence void warnings
+
+ * Added ability to declare lexically scoped wrapper subs
+ (thanks Schwern!)
+
+ * Documented incompatibility with Moose
+ (thanks Torbjørn!)
+
+ * Handle terminal escape sequences (e.g. arrow keys) more gracefully
+ (Thanks, Lukasz!)
+
+
+0.004013 Thu Jul 23 07:15:57 2015
+
+ * Added better default ERASE character for MSWin32 (thanks Dan!)
+
+ * Silenced warnings within test for valid input
+ (Thanks Joel!)
+
+
+0.004014 Tue Nov 24 08:50:00 2015
+
+ * Numerous improvements to completion behaviour
+ (Many thanks, Victor, and apologies for the long delay!)
+
+
+0.004015 Sat Dec 8 06:53:05 2018
+
+ * Added warning about limitations under Windows
+ (Thanks, Jan!)
+
+ * Added warning about prompt() returning object not string
+ (Merci, Mirod!)
diff --git a/MANIFEST b/MANIFEST
new file mode 100644
index 0000000..095e525
--- /dev/null
+++ b/MANIFEST
@@ -0,0 +1,45 @@
+Changes
+MANIFEST
+Makefile.PL
+README
+lib/IO/Prompter.pm
+t/00.load.t
+t/pod-coverage.t
+t/pod.t
+t/argv.t
+t/bundled.t
+t/default.t
+t/errors.t
+t/fail.t
+t/fake.t
+t/fake_no_term_readkey.t
+t/filehandles.t
+t/integer.t
+t/interactive.t
+t/interactive_echo.t
+t/interactive_no_term_readkey.t
+t/interactive_out.t
+t/interactive_return.t
+t/interactive_wipe.t
+t/interactive_wipe_wipefirst.t
+t/interactive_wipefirst.t
+t/line.t
+t/must.t
+t/no_term_readkey.t
+t/number.t
+t/simple.t
+t/single.t
+t/timeout.t
+t/timeout_no_term_readkey.t
+t/verbatim.t
+t/yesno.t
+t/zen.t
+t/guarantee.t
+t/keyletters.t
+t/orlast.t
+t/styles.t
+t/lexical_options.t
+t/list_context.t
+t/autoexport.t
+META.yml Module YAML meta-data (added by MakeMaker)
+META.json Module JSON meta-data (added by MakeMaker)
diff --git a/META.json b/META.json
new file mode 100644
index 0000000..c75dc77
--- /dev/null
+++ b/META.json
@@ -0,0 +1,42 @@
+{
+ "abstract" : "Prompt for input, read it, clean it, return it.",
+ "author" : [
+ "Damian Conway <DCONWAY@CPAN.org>"
+ ],
+ "dynamic_config" : 1,
+ "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.143240",
+ "license" : [
+ "perl_5"
+ ],
+ "meta-spec" : {
+ "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
+ "version" : 2
+ },
+ "name" : "IO-Prompter",
+ "no_index" : {
+ "directory" : [
+ "t",
+ "inc"
+ ]
+ },
+ "prereqs" : {
+ "build" : {
+ "requires" : {
+ "ExtUtils::MakeMaker" : "0"
+ }
+ },
+ "configure" : {
+ "requires" : {
+ "ExtUtils::MakeMaker" : "0"
+ }
+ },
+ "runtime" : {
+ "requires" : {
+ "Contextual::Return" : "0",
+ "Test::More" : "0"
+ }
+ }
+ },
+ "release_status" : "stable",
+ "version" : "0.004015"
+}
diff --git a/META.yml b/META.yml
new file mode 100644
index 0000000..8f1195d
--- /dev/null
+++ b/META.yml
@@ -0,0 +1,23 @@
+---
+abstract: 'Prompt for input, read it, clean it, return it.'
+author:
+ - 'Damian Conway <DCONWAY@CPAN.org>'
+build_requires:
+ ExtUtils::MakeMaker: '0'
+configure_requires:
+ ExtUtils::MakeMaker: '0'
+dynamic_config: 1
+generated_by: 'ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.143240'
+license: perl
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: '1.4'
+name: IO-Prompter
+no_index:
+ directory:
+ - t
+ - inc
+requires:
+ Contextual::Return: '0'
+ Test::More: '0'
+version: '0.004015'
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..3cf7b29
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,18 @@
+use strict;
+use warnings;
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ NAME => 'IO::Prompter',
+ AUTHOR => 'Damian Conway <DCONWAY@CPAN.org>',
+ VERSION_FROM => 'lib/IO/Prompter.pm',
+ ABSTRACT_FROM => 'lib/IO/Prompter.pm',
+ LICENSE => 'perl',
+ PL_FILES => {},
+ PREREQ_PM => {
+ 'Test::More' => 0,
+ 'Contextual::Return' => 0,
+ },
+ dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
+ clean => { FILES => 'IO-Prompter-*' },
+);
diff --git a/README b/README
new file mode 100644
index 0000000..55275a4
--- /dev/null
+++ b/README
@@ -0,0 +1,51 @@
+IO::Prompter version 0.004015
+
+Prompt for, read, vet, chomp, and encapsulate input.
+Like so:
+
+ use IO::Prompter;
+
+ while (prompt -num 'Enter a number') {
+ say "You entered: $_";
+ }
+
+ my $passwd
+ = prompt 'Enter your password', -echo=>'*';
+
+ my $selection
+ = prompt 'Choose wisely...', -menu => {
+ wealth => [ 'moderate', 'vast', 'incalculable' ],
+ health => [ 'hale', 'hearty', 'rude' ],
+ wisdom => [ 'cosmic', 'folk' ],
+ }, '>';
+
+
+INSTALLATION
+
+To install this module, run the following commands:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+Alternatively, to install with Module::Build, you can use the following commands:
+
+ perl Build.PL
+ ./Build
+ ./Build test
+ ./Build install
+
+
+DEPENDENCIES
+
+Requires Contextual::Return.
+Works much better if Term::ReadKey is installed.
+
+
+COPYRIGHT AND LICENCE
+
+Copyright (C) 2009, Damian Conway
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
diff --git a/lib/IO/Prompter.pm b/lib/IO/Prompter.pm
new file mode 100644
index 0000000..94f276c
--- /dev/null
+++ b/lib/IO/Prompter.pm
@@ -0,0 +1,3596 @@
+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 <ESC> 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 <ESC> implies the current faked line is deferred...
+ if ($lookahead eq $FAKE_ESC) {
+ $fake_input =~ s{ \A }{$orig_fake_input\n}xm;
+ }
+ # Only one <ESC> 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<boldly strong heavy emphasis emphatic highlight highlighted fort forte>],
+ dark => [qw<darkly dim deep>],
+ faint => [qw<faintly light soft>],
+ underline => [qw<underlined underscore underscored italic italics>],
+ blink => [qw<blinking flicker flickering flash flashing>],
+ reverse => [qw<reversed inverse inverted>],
+ concealed => [qw<hidden blank invisible>],
+ reset => [qw<normal default standard usual ordinary regular>],
+ 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__
+
+=head1 NAME
+
+IO::Prompter - Prompt for input, read it, clean it, return it.
+
+
+=head1 VERSION
+
+This document describes IO::Prompter version 0.004015
+
+
+=head1 SYNOPSIS
+
+ use IO::Prompter;
+
+ while (prompt -num, 'Enter a number') {
+ say "You entered: $_";
+ }
+
+ my $passwd
+ = prompt 'Enter your password', -echo=>'*';
+
+ my $selection
+ = prompt 'Choose wisely...', -menu => {
+ wealth => [ 'moderate', 'vast', 'incalculable' ],
+ health => [ 'hale', 'hearty', 'rude' ],
+ wisdom => [ 'cosmic', 'folk' ],
+ }, '>';
+
+
+=head1 CAVEATS
+
+=over
+
+=item 1.
+
+Several features of this module are known to have problems under
+Windows. If using that platform, you may have more success
+(and less distress) by trying IO::Prompt::Tiny, IO::Prompt::Simple,
+or IO::Prompt::Hooked first.
+
+=item 2.
+
+By default the C<prompt()> subroutine does not return a string; it
+returns an object with overloaded string and boolean conversions.
+This object B<I<always>> evaluates true in boolean contexts, unless the
+read operation actually failed. This means that the object evaluates
+true I<even when the input value is zero or
+an empty string.> See L<"Returning raw data"> to turn off this
+(occasionally counter-intuitive) behaviour.
+
+=back
+
+=head1 DESCRIPTION
+
+IO::Prompter exports a single subroutine, C<prompt>, that prints a
+prompt (but only if the program's selected input and output streams are
+connected to a terminal), then reads some input, then chomps it, and
+finally returns an object representing that text.
+
+The C<prompt()> subroutine expects zero-or-more arguments.
+
+Any argument that starts with a hyphen (C<->) is treated as a named
+option (many of which require an associated value, that may be passed as
+the next argument). See L<"Summary of options"> and L<"Options
+reference"> for details of the available options.
+
+Any other argument that is a string is treated as (part of) the prompt
+to be displayed. All such arguments are concatenated together before the
+prompt is issued. If no prompt string is provided, the string
+C<< '> ' >> is used instead.
+
+Normally, when C<prompt()> is called in either list or scalar context,
+it returns an opaque object that autoconverts to a string. In scalar
+boolean contexts this return object evaluates true if the input
+operation succeeded. In list contexts, if the input operation fails
+C<prompt()> returns an empty list instead of a return object. This
+allows failures in list context to behave correctly (i.e. be false).
+
+If you particularly need a list-context call to C<prompt()> to always
+return a value (i.e. even on failure), prefix the call with C<scalar>:
+
+ # Only produces as many elements
+ # as there were successful inputs...
+ my @data = (
+ prompt(' Name:'),
+ prompt(' Age:'),
+ prompt('Score:'),
+ );
+
+ # Always produces exactly three elements
+ # (some of which may be failure objects)...
+ my @data = (
+ scalar prompt(' Name:'),
+ scalar prompt(' Age:'),
+ scalar prompt('Score:'),
+ );
+
+In void contexts, C<prompt()> still requests input, but also issues a
+warning about the general uselessness of performing an I/O operation
+whose results are then immediately thrown away.
+See L<"Useful useless uses of C<prompt()>"> for an exception to this.
+
+The C<prompt()> function also sets C<$_> if it is called in a boolean
+context but its return value is not assigned to a variable. Hence, it is
+designed to be a drop-in replacement for C<readline> or C<< <> >>.
+
+=head1 INTERFACE
+
+All the options for C<prompt()> start with a hyphen (C<->).
+Most have both a short and long form. The short form is always
+the first letter of the long form.
+
+Most options have some associated value. For short-form options, this
+value is specified as a string appended to the option itself. The
+associated value for long-form options is always specified as a
+separated argument, immediately following the option (typically
+separated from it by a C<< => >>).
+
+Note that this implies that short-form options may not be able to
+specify every possible associated value (for example, the short-form
+C<-d> option cannot specify defaults with values C<'efault'> or
+C<'$%^!'>). In such cases, just use the long form of the option
+(for example: S<< C<< -def => 'efault' >> >> or C<< -default=>'$%^!' >>).
+
+
+=head2 Summary of options
+
+Note: For options preceded by an asterisk, the short form is actually
+a Perl file operator, and hence cannot be used by itself.
+Either use the long form of these options,
+or L<bundle them with another option|"Bundling short-form options">,
+or add a L<"no-op"|"Escaping otherwise magic options"> to them.
+
+
+ Short Long
+ form form Effect
+ ===== ============= ======================================
+
+ -a -argv Prompt for @ARGV data if !@ARGV
+
+ -comp[lete]=>SPEC Complete input on <TAB>, as specified
+
+ -dSTR -def[ault]=>STR What to return if only <ENTER> typed
+ -DEF[AULT]=>STR (as above, but skip any -must checking)
+
+ * -e[STR] -echo=>STR Echo string for each character typed
+
+ -echostyle=>SPEC What colour/style to echo input in
+
+ * -f -filenames Input should be name of a readable file
+
+ -fail=>VALUE Return failure if input smartmatches value
+
+ -guar[antee]=>SPEC Only allow the specified words to be entered
+
+ -h[STR] -hist[ory][=>SPEC] Specify the history set this call belongs to
+
+ -in=>HANDLE Read from specified handle
+
+ -i -integer[=>SPEC] Accept only valid integers (that smartmatch SPEC)
+
+ -k -keyletters Accept only keyletters (as specified in prompt)
+
+ * -l -line Don't autochomp
+
+ -menu=>SPEC Specify a menu of responses to be displayed
+
+ -must=>HASHREF Specify requirements/constraints on input
+
+ -n -num[ber][=>SPEC] Accept only valid numbers (that smartmatch SPEC)
+
+ -out=>HANDLE Prompt to specified handle
+
+ -prompt=>STR Specify prompt explicitly
+
+ * -rSTR -ret[urn]=>STR After input, echo this string instead of <CR>
+
+ * -s -1 -sing[le] Return immediately after first key pressed
+
+ -stdio Use STDIN and STDOUT for prompting
+
+ -style=>SPEC What colour/style to display the prompt text in
+
+ -tNUM -time[out]=>NUM Specify a timeout on the input operation
+
+ -v -verb[atim] Return the input string (no context sensitivity)
+
+ -void Don't complain in void context
+
+ * -w -wipe Clear screen
+ -wipefirst Clear screen on first prompt() call only
+
+ * -y -yes [=> NUM] Return true if [yY] entered, false otherwise
+ -yn -yesno [=> NUM] Return true if [yY] entered, false if [nN]
+ -Y -Yes [=> NUM] Return true if Y entered, false otherwise
+ -YN -YesNo [=> NUM] Return true if Y entered, false if N
+
+ * -_ No-op (handy for bundling ambiguous short forms)
+
+
+=head2 Automatic options
+
+Any of the options listed above (and described in detail below) can be
+automatically applied to every call to C<prompt()> in the current
+lexical scope, by passing them (via an array reference) as the arguments
+to a C<use IO::Prompter> statement.
+
+For example:
+
+ use IO::Prompter;
+
+ # This call has no automatically added options...
+ my $assent = prompt "Do you wish to take the test?", -yn;
+
+ {
+ use IO::Prompter [-yesno, -single, -style=>'bold'];
+
+ # These three calls all have: -yesno, -single, -style=>'bold' options
+ my $ready = prompt 'Are you ready to begin?';
+ my $prev = prompt 'Have you taken this test before?';
+ my $hints = prompt 'Do you want hints as we go?';
+ }
+
+ # This call has no automatically added options...
+ scalar prompt 'Type any key to start...', -single;
+
+The current scope's lexical options are always I<prepended> to the
+argument list of any call to C<prompt()> in that scope.
+
+To turn off any existing automatic options for the rest of the current
+scope, use:
+
+ use IO::Prompter [];
+
+
+=head2 Prebound options
+
+You can also ask IO::Prompter to export modified versions of C<prompt()>
+with zero or more options prebound. For example, you can request an
+C<ask()> subroutine that acts exactly like C<prompt()> but has the C<-
+yn> option pre-specified, or a C<pause()> subroutine that is C<prompt()>
+with a "canned" prompt and the C<-echo>, C<-single>, and C<-void> options.
+
+To specify such subroutines, pass a single hash reference when
+loading the module:
+
+ use IO::Prompter {
+ ask => [-yn],
+ pause => [-prompt=>'(Press any key to continue)', -echo, -single, -void],
+ }
+
+Each key will be used as the name of a separate subroutine to be
+exported, and each value must be an array reference, containing the
+arguments that are to be automatically supplied.
+
+The resulting subroutines are simply lexically scoped wrappers around
+C<prompt()>, with the specified arguments prepended to the normal
+argument list, equivalent to something like:
+
+ my sub ask {
+ return prompt(-yn, @_);
+ }
+
+ my sub pause {
+ return prompt(-prompt=>'(Press any key to continue)', -echo, -single, -void, @_);
+ }
+
+Note that these subroutines are lexically scoped, so if you want to use
+them throughtout a source file, they should be declared in the outermost
+scope of your program.
+
+
+=head2 Options reference
+
+=head3 Specifying what to prompt
+
+=over 4
+
+C<< -prompt => I<STRING> >>
+
+C<< -pI<STRING> >>
+
+=back
+
+By default, any argument passed to C<prompt()> that does not begin with
+a hyphen is taken to be part of the prompt string to be displayed before
+the input operation. Moreover, if no such string is specified in the
+argument list, the function supplies a default prompt (C<< '> ' >>)
+automatically.
+
+The C<-prompt> option allows you to specify a prompt explicitly, thereby
+enabling you to use a prompt that starts with a hyphen:
+
+ my $input
+ = prompt -prompt=>'-echo';
+
+or to disable prompting entirely:
+
+ my $input
+ = prompt -prompt => "";
+
+Note that the use of the C<-prompt> option doesn't override other string
+arguments, it merely adds its argument to the collective prompt.
+
+=head4 Prompt prettification
+
+If the specified prompt ends in a non-whitespace character, C<prompt()>
+adds a single space after it, to better format the output. On the other
+hand, if the prompt ends in a newline, C<prompt()> removes that
+character, to keep the input position on the same line as the prompt.
+
+You can use that second feature to override the first, if necessary. For
+example, if you wanted your prompt to look like:
+
+ Load /usr/share/dict/_
+
+(where the _ represents the input cursor), then a call like:
+
+ $filename = prompt 'Load /usr/share/dict/';
+
+would not work because it would automatically add a space, producing:
+
+ Load /usr/share/dict/ _
+
+But since a terminal newline is removed, you could achieve the desired effect
+with:
+
+ $filename = prompt "Load /usr/share/dict/\n";
+
+If for some reason you I<do> want a newline at the end of the prompt (i.e.
+with the input starting on the next line) just put two newlines at the end
+of the prompt. Only the very last one will be removed.
+
+
+=head3 Specifying how the prompt looks
+
+=over 4
+
+C<< -style => I<SPECIFICATION> >>
+
+=back
+
+If the C<Term::ANSIColor> module is available, this option can be used
+to specify the colour and styling (e.g. bold, inverse, underlined, etc.)
+in which the prompt is displayed.
+
+You can can specify that styling as a single string:
+
+ prompt 'next:' -style=>'bold red on yellow';
+
+or an array of styles:
+
+ prompt 'next:' -style=>['bold', 'red', 'on_yellow'];
+
+The range of styles and colour names that the option understands is
+quite extensive. All of the following work as expected:
+
+ prompt 'next:' -style=>'bold red on yellow';
+
+ prompt 'next:' -style=>'strong crimson on gold';
+
+ prompt 'next:' -style=>'highlighted vermilion, background of cadmium';
+
+ prompt 'next:' -style=>'vivid russet over amber';
+
+ prompt 'next:' -style=>'gules fort on a field or';
+
+However, because C<Term::ANSIColor> maps everything back to the
+standard eight ANSI text colours and seven ANSI text styles, all of the
+above will also be rendered identically. See that module's
+documentation for details.
+
+If C<Term::ANSIColor> is not available, this option is silently ignored.
+
+Please bear in mind that up to 10% of people using your interface will
+have some form of colour vision impairment, so its always a good idea
+to differentiate information by style I<and> colour, rather than by colour
+alone. For example:
+
+ if ($dangerous_action) {
+ prompt 'Really proceed?', -style=>'bold red underlined';
+ }
+ else {
+ prompt 'Proceed?', -style=>'green';
+ }
+
+Also bear in mind that (even though C<-style> does support the C<'blink'>
+style) up to 99% of people using your interface will have Flashing Text
+Tolerance Deficiency. Just say "no".
+
+
+=head3 Specifying where to prompt
+
+=over 4
+
+C<< -out => FILEHANDLE >>
+
+C<< -in => FILEHANDLE >>
+
+C<< -stdio >>
+
+=back
+
+The C<-out> option (which has no short form) is used to specify
+where the prompt should be written to. If this option is not specified,
+prompts are written to the currently C<select>-ed filehandle. The most
+common usage is:
+
+ prompt(out => *STDERR)
+
+The C<-in> option (which also has no short form) specifies where the input
+should be read from. If this option is not specified, input is read from
+the C<*ARGV> filehandle. The most common usage is:
+
+ prompt(in => *STDIN)
+
+in those cases where C<*ARGV> has been opened to a file, but you still
+wish to interact with the terminal (assuming C<*STDIN> is opened to that
+terminal).
+
+The C<-stdio> option (which again has no short form) is simply a shorthand
+for: C<< -in => *STDIN, -out => *STDOUT >>. This is particularly useful when
+there are arguments on the commandline, but you don't want prompt to treat
+those arguments as filenames for magic C<*ARGV> reads.
+
+
+=head3 Specifying how long to wait for input
+
+=over 4
+
+C<< -timeout => I<N> >>
+
+C<< -tI<N> >>
+
+=back
+
+Normally, the C<prompt()> function simply waits for input. However,
+you can use this option to specify a timeout on the read operation.
+If no input is received within the specified I<N> seconds, the call
+to C<prompt()> either returns the value specified by
+L<the C<-default> option|"Specifying what to return by default">
+(if any), or else an object indicating the read failed.
+
+Note that, if the short form is used, I<N> must be an integer. If the long
+form is used, I<N> may be an integer or floating point value.
+
+You can determine whether an input operation timed out, even if a
+default value was returned, by calling the C<timedout()> method on the
+object returned by C<prompt()>:
+
+ if (prompt('Continue?', -y1, -timeout=>60) && !$_->timedout) {
+ ...
+ }
+
+If a time-out occurred, the return value of C<timedout()> is a string
+describing the timeout, such as:
+
+ "timed out after 60 seconds"
+
+
+=head3 Providing a menu of responses
+
+=over
+
+=item C<< -menu => I<SPECIFICATION> >>
+
+=back
+
+You can limit the allowable responses to a prompt, by providing a menu.
+
+A menu is specified using the C<-menu> option, and the menu choices
+are specified as an argument to the option, either as a reference to
+an array, hash, or string, or else as a literal string.
+
+If the menu is specified in a hash, C<prompt()> displays the keys of the
+hash, sorted alphabetically, and with each alternative marked with a
+single alphabetic character (its "selector key").
+
+For example, given:
+
+ prompt 'Choose...',
+ -menu=>{ 'live free'=>1, 'die'=>0, 'transcend'=>-1 },
+ '>';
+
+C<prompt()> will display:
+
+ Choose...
+ a. die
+ b. live free
+ c. transcend
+ > _
+
+It will then only permit the user to enter a valid selector key (in the
+previous example: 'a', 'b', or 'c'). Once one of the alternatives is
+selected, C<prompt()> will return the corresponding value from the hash
+(0, 1, or -1, respectively, in this case).
+
+Note that the use of alphabetics as selector keys inherently limits the
+number of usable menu items to 52. See L<"Numeric menus"> for a way to
+overcome this limitation.
+
+A menu is treated like a special kind of prompt, so that any
+other prompt strings in the C<prompt()> call will appear either before or
+after the menu of choices, depending on whether they appear before or
+after the menu specification in the call to C<prompt()>.
+
+If an array is used to specify the choices:
+
+ prompt 'Choose...',
+ -menu=>[ 'live free', 'die', 'transcend' ],
+ '>';
+
+then each array element is displayed (in the original array order) with
+a selector key:
+
+ Choose...
+ a. live free
+ b. die
+ c. transcend
+ > _
+
+and C<prompt()> returns the element corresponding to the selection (i.e.
+it returns 'live free' if 'a' is entered, 'die' if 'b' is entered, or
+'transcend' if 'c' is entered).
+
+Hence, the difference between using an array and a hash is that the
+array allows you to control the order of items in the menu, whereas a
+hash allows you to show one thing (i.e. keys) but have something related
+(i.e. values) returned instead.
+
+If the argument after C<-menu> is a string or a reference to a string, the
+option splits the string on newlines, and treats the resulting list as if it
+were an array of choices. This is useful, for example, to request the user
+select a filename:
+
+ my $files = `ls`;
+ prompt 'Select a file...', -menu=>$files, '>';
+
+
+=head4 Numbered menus
+
+As the previous examples indicate, each menu item is given a unique
+alphabetic selector key. However, if the C<-number> or C<-integer>
+option is specified as well:
+
+ prompt 'Choose...',
+ -number,
+ -menu=>{ 'live free'=>1, 'die'=>0, 'transcend'=>-1 },
+ '>';
+
+C<prompt()> will number each menu item instead, using consecutive integers
+as the selector keys:
+
+ Choose...
+ 1. die
+ 2. live free
+ 3. transcend
+ > _
+
+This allows for an unlimited number of alternatives in a single menu,
+but prevents the use of C<-single> for one-key selection from menus if
+the menu has more than nine items.
+
+
+=head4 Hierarchical menus
+
+If you use a hash to specify a menu, the values of the hash do not have
+to be strings. Instead, they can be references to nested hashes or
+arrays.
+
+This allows you to create hierarchical menus, where a selection at the
+top level may lead to a secondary menu, etc. until an actual choice is
+possible. For example, the following call to prompt:
+
+ my $choices = {
+ animates => {
+ animals => {
+ felines => [qw<cat lion lynx>],
+ canines => [qw<dog fox wolf>],
+ bovines => [qw<cow ox buffalo>],
+ },
+ fish => [qw<shark carp trout bream>],
+ },
+ inanimates => {
+ rocks => [qw<igneous metamorphic sedimentary>],
+ languages => [qw<Perl Python Ruby Tcl>],
+ },
+ };
+
+ my $result = prompt -1, 'Select a species...', -menu=>$choices, '> ';
+
+might result in an interaction like this:
+
+ Select a species...
+ a. animates
+ b. inanimates
+ > a
+
+ Select from animates:
+ a. animals
+ b. fish
+ > b
+
+ Select from fish:
+ a. shark
+ b. carp
+ c. trout
+ d. bream
+ > c
+
+At which point, C<prompt()> would return the string C<'trout'>.
+
+Note that you can nest an arbitrary number of hashes, but that each
+"bottom" level choice has to be either a single string, or an array
+of strings.
+
+
+=head4 Navigating hierarchical menus
+
+Within a hierarchical menu, the user must either select a valid option
+(by entering the corresponding letter), or else may request that they be
+taken back up a level in the hierarchy, by entering C<< <ESC> >>.
+Pressing C<< <ESC> >> at the top level of a menu causes the call to
+C<prompt()> to immediately return with failure.
+
+
+=head3 Simulating a command-line
+
+=over 4
+
+C<< -argv >>
+
+C<< -a >>
+
+=back
+
+The C<prompt()> subroutine can be used to request that the user provide
+command-line arguments interactively. When requested, the input
+operation is only carried out if C<@ARGV> is empty.
+
+Whatever the user enters is broken into a list and assigned to C<@ARGV>.
+
+The input is first C<glob>bed for file expansions, and has any
+environment variables (of the form C<$VARNAME> interpolated). The
+resulting string is then broken into individual words, except where
+parts of it contain single or double quotes, the contents of which are
+always treated as a single string.
+
+This feature is most useful during development, to allow a program to be
+run from within an editor, and yet pass it a variety of command-lines. The
+typical usage is (at the start of a program):
+
+ use IO::Prompter;
+ BEGIN { prompt -argv }
+
+However, because this pattern is so typical, there is a shortcut:
+
+ use IO::Prompter -argv;
+
+You can also specify the name with which the program args, are to
+be prompted, in the usual way (i.e. by providing a prompt):
+
+ use IO::Prompter -argv, 'demo.pl';
+
+Note, however, the critical difference between that shortcut
+(which calls C<prompt -argv> when the module is loaded) and:
+
+ use IO::Prompter [-argv];
+
+(which sets C<-argv> as an automatic option for every subsequent call to
+C<prompt()> in the current lexical scope).
+
+Note too that the C<-argv> option also implies C<-complete=>'filenames'>.
+
+
+=head3 Input autocompletion
+
+=over 4
+
+C<< -comp[lete] => I<SPECIFICATION> >>
+
+=back
+
+When this option is specified, the C<prompt()> subroutine will complete
+input using the specified collection of strings. By default, when
+completion is active, word completion is requested using the C<< <TAB> >>
+key, but this can be changed by setting the C<$IO_PROMPTER_COMPLETE_KEY>
+environment variable. Once completion has been initiated, you can use
+the completion key or else C<< <CTRL-N> >> to advance to the next completion
+candidate. You can also use C<< <CTRL-P> >> to back up to the previous
+candidate.
+
+The specific completion mechanism can be defined either using a
+subroutine, an array reference, a hash reference, or a special string:
+
+ Specification Possible completions supplied by...
+
+ sub {...} ...whatever non-subroutine specification
+ (as listed below) is returned when the
+ subroutine is called. The subroutine is passed
+ the words of the current input text, split on
+ whitespace, as its argument list.
+
+ [...] ...the elements of the array
+
+ {...} ...the keys of the hash
+
+ 'filenames' ...the list of files supplied by globbing the
+ last whitespace-separated word of the input text
+
+ 'dirnames' ...the list of directories supplied by globbing the
+ last whitespace-separated word of the input text
+
+If an array or hash is used, only those elements or keys that begin with
+the last whitespace-separated word of the current input are offered as
+completions.
+
+For example:
+
+ # Complete with the possible commands...
+ my $next_cmd
+ = prompt -complete => \%cmds;
+
+ # Complete with valid usernames...
+ my $user
+ = prompt -complete => \@usernames;
+
+ # Complete with valid directory names...
+ my $file
+ = prompt -complete => 'dirnames';
+
+ # Complete with cmds on the first word, and filenames on the rest...
+ my $cmdline
+ = prompt -complete => sub { @_ <= 1 ? \%cmds : 'filenames' };
+
+
+=head4 Completing from your own input history
+
+The C<prompt()> subroutine also tracks previous input and allows you to
+complete with that instead. No special option is required, as the
+feature is enabled by default.
+
+At the start of a prompted input, the user can cycle backwards through
+previous inputs by pressing C<< <CTRL-R> >> (this can be changed
+externally by setting the C<$IO_PROMPTER_HISTORY_KEY> environment
+variable, or internally by assigning a new keyname to
+C<$ENV{IO_PROMPTER_HISTORY_KEY}>). After the first C<< <CTRL-R> >>,
+subsequent C<< <CTRL-R> >>'s will recall earlier inputs. You can also
+use C<< <CTRL-N> >> and C<< <CTRL-P> >>
+(as in L<user-specified completions|"Input autocompletion">) to move
+back and forth through your input history.
+
+If the user has already typed some input, the completion mechanism
+will only show previous inputs that begin with that partial input.
+
+
+=head4 History sets
+
+=over 4
+
+=item C<< -h[NAME] >>
+
+=item C<< -hist[ory] [=> NAME] >>
+
+=back
+
+By default, IO::Prompter tracks every call to C<prompt()> within a
+program, and accumulates a single set of history completions for all of
+them. That means that, at any prompt, C<< <CTRL-R> >> will take the user
+back through I<every> previous input, regardless of which call to
+C<prompt()> originally retrieved it.
+
+Sometimes that's useful, but sometimes you might prefer that different
+calls to C<prompt()> retained distinct memories. For example, consider
+the following input loop:
+
+ while (my $name = prompt 'Name:') {
+ my $grade = prompt 'Grade:', -integer;
+ my $comment = prompt 'Comment:';
+ ...
+ }
+
+If you're entering a name, there's no point in C<prompt()> offering
+to complete it with previous grades or comments. In fact, that's
+just annoying.
+
+IO::Prompter allows you to specify that a particular call to
+C<prompt()> belongs to a particular "history set". Then it completes
+input history using only the history of those calls belonging to the
+same history set.
+
+So the previous example could be improved like so:
+
+ while (my $name = prompt 'Name:', -hNAME) {
+ my $grade = prompt 'Grade:', -hGRADE, -integer;
+ my $comment = prompt 'Comment:', -hOTHER;
+ ...
+ }
+
+Now, when prompting for a name, only those inputs in the C<'NAME'>
+history set will be offered as history completions. Likewise only
+previous grades will be recalled when prompting for grades and earlier
+only comments when requesting comments.
+
+If you specify the C<-h> or C<-history> option without providing the
+name of the required history set, C<prompt()> uses the prompt text
+itself as the name of the call's history set. So the previous example
+would work equally well if written:
+
+ while (my $name = prompt 'Name:', -h) {
+ my $grade = prompt 'Grade:', -h, -integer;
+ my $comment = prompt 'Comment:', -h;
+ ...
+ }
+
+though now the names of the respective history sets would now be
+C<'Name: '>, C<'Grade: '>, and C<'Comment: '>. This is by far the more
+common method of specifying history sets, with explicitly named sets
+generally only being used when two or more separate calls to
+C<prompt()> have to share a common history despite using distinct
+prompts. For example:
+
+ for my $n (1..3) {
+ $address .= prompt "Address (line $n):", -hADDR;
+ }
+
+If you specify C<'NONE'> as the history set, the input is not
+recorded in the history. This is useful when inputting passwords.
+
+
+=head4 Configuring the autocompletion interaction
+
+By default, when user-defined autocompletion is requested, the
+C<prompt()> subroutine determines the list of possible completions,
+displays it above the prompt, and completes to the longest common
+prefix. If the completion key is pressed again immediately, the
+subroutine then proceeds to complete with each possible completion in a
+cyclic sequence. This is known as "list+longest full" mode.
+
+On the other hand, when historical completion is requested, C<prompt()>
+just immediately cycles through previous full inputs. This is known as "full"
+mode.
+
+You can change these behaviours by setting the
+C<$IO_PROMPTER_COMPLETE_MODES> and C<$IO_PROMPTER_HISTORY_MODES>
+environment variables I<before the module is loaded> (either in your shell,
+or in a C<BEGIN> block before the module is imported).
+
+Specifically, you can set the individual string values of either of
+these variables to a whitespace-separated sequence containing any of the
+following:
+
+ list List all options above the input line
+
+ longest Complete to the longest common prefix
+
+ full Complete with each full match in turn
+
+For example:
+
+ # Just list options without actually completing...
+ BEGIN{ $ENV{IO_PROMPTER_COMPLETE_MODES} = 'list'; }
+
+ # Just cycle full alternatives on each <TAB>...
+ BEGIN{ $ENV{IO_PROMPTER_COMPLETE_MODES} = 'full'; }
+
+ # For history completion, always start with the
+ # longest common prefix on the first <CTRL-R>,
+ # then just list the alternatives on a subsequent press...
+ BEGIN{ $ENV{IO_PROMPTER_HISTORY_MODES} = 'longest list'; }
+
+
+=head3 Specifying what to return by default
+
+=over
+
+C<< -DEF[AULT] => I<STRING> >>
+
+C<< -def[ault] => I<STRING> >>
+
+C<< -dI<STRING> >>
+
+=back
+
+If a default value is specified, that value will be returned if the user
+enters an empty string at the prompt (i.e. if they just hit
+C<< <ENTER>/<RETURN> >> immediately) or if the input operation times out under
+L<the C<timeout> option|"Specifying how long to wait for input">.
+
+Note that the default value is not added to the prompt, unless you
+do so yourself. A typical usage might therefore be:
+
+ my $frequency
+ = prompt "Enter polling frequency [default: $DEF_FREQ]",
+ -num, -def=>$DEF_FREQ;
+
+You can determine if the default value was autoselected (as opposed to
+the same value being typed in explicitly) by calling the C<defaulted()>
+method on the object returned by C<prompt()>, like so:
+
+ if ($frequency->defaulted) {
+ say "Using default frequency";
+ }
+
+If you use the L<< C<-must> option|"Constraining what can be returned" >>
+any default value must also satisfy all the constraints you specify,
+unless you use the C<-DEFAULT> form, which skips constraint checking
+when the default value is selected.
+
+If you use the L<< C<-menu> option|"Providing a menu of responses" >>,
+the specified default value will be returned immediately C<< <ENTER>/<RETURN> >> is
+pressed, regardless of the depth you are within the menu. Note that the
+default value specifies the value to be returned, not the selector key
+to be entered. The default value does not even have to be one of the
+menu choices.
+
+
+=head3 Specifying what to echo on input
+
+=over
+
+C<< -echo => I<STR> >>
+
+C<< -eI<STR> >>
+
+=back
+
+When this option is specified, the C<prompt()> subroutine will echo the
+specified string once for each character that is entered. Typically this
+would be used to shroud a password entry, like so:
+
+ # Enter password silently:
+ my $passwd
+ = prompt 'Password:', -echo=>"";
+
+ # Echo password showing only asterisks:
+ my $passwd
+ = prompt 'Password:', -echo=>"*";
+
+As a special case, if the C<-echo> value contains a slash (C</>) and the
+any of the <-yesno> options is also specified, the substring before the
+slash is taken as the string to echo for a 'yes' input, and the
+substring after the slash is echoed for a 'no' input.
+
+Note that this option is only available when the Term::ReadKey module
+is installed. If it is used when that module is not available, a warning
+will be issued.
+
+
+=head4 Specifying how to echo on input
+
+C<< -echostyle => I<SPECIFICATION> >>
+
+The C<-echostyle> option works for the text the user types in
+the same way that the C<-style> option works for the prompt.
+That is, you can specify the style and colour in which the user's
+input will be rendered like so:
+
+ # Echo password showing only black asterisks on a red background:
+ my $passwd
+ = prompt 'Password:', -echo=>"*", -echostyle=>'black on red';
+
+Note that C<-echostyle> is completely independent of C<-echo>:
+
+ # Echo user's name input in bold white:
+ my $passwd
+ = prompt 'Name:', -echostyle=>'bold white';
+
+The C<-echostyle> option requires C<Term::ANSIColor>, and will
+be silently ignored if that module is not available.
+
+
+=head4 Input editing
+
+When the Term::ReadKey module is available, C<prompt()> also honours a
+subset of the usual input cursor motion commands:
+
+=over
+
+=item C<CTRL-B>
+
+Move the cursor back one character
+
+=item C<CTRL-F>
+
+Move the cursor forward one character
+
+=item C<CTRL-A>
+
+Move the cursor to the start of the input
+
+=item C<CTRL-E>
+
+Move the cursor to the end of the input
+
+=back
+
+
+=head3 Specifying when input should fail
+
+=over 4
+
+C<< -fail => I<VALUE> >>
+
+C<< -fI<STRING> >>
+
+=back
+
+If this option is specified, the final input value is compared with the
+associated string or value, by smartmatching just before the call to
+C<prompt()> returns. If the two match, C<prompt()> returns a failure
+value. This means that instead of writing:
+
+ while (my $cmd = prompt '>') {
+ last if $cmd eq 'quit';
+ ...
+ }
+
+you can just write:
+
+ while (my $cmd = prompt '>', -fail=>'quit') {
+ ...
+ }
+
+
+=head3 Constraining what can be typed
+
+=over 4
+
+=item C<< -guar[antee] => SPEC >>
+
+=back
+
+This option allows you to control what input users can provide.
+The specification can be a regex or a reference to an array or a hash.
+
+If the specification is a regex, that regex is matched against the input
+so far, every time an extra character is input. If the regex ever fails
+to match, the guarantee fails.
+
+If the specification is an array, the input so far is matched against
+the same number of characters from the start of each of the (string)
+elements of the array. If none of these substrings match the input, the
+guarantee fails.
+
+If the specification is a hash, the input so far is matched against the
+same number of characters from the start of each key of the hash. If
+none of these substrings match the input, the guarantee fails.
+
+If the guarantee fails, the input is rejected
+(just as L<< the C<-must> option|"Constraining what can be returned" >>
+does). However, unlike C<-must>, C<-guarantee> rejects the input
+character-by-character as it typed, and I<before> it is even echoed. For
+example, if your call to C<prompt()> is:
+
+ my $animal = prompt -guarantee=>['cat','dog','cow'];
+
+then at the prompt:
+
+ > _
+
+you will only be able to type in 'c' or 'd'. If you typed 'c', then you would
+only be able to type 'a' or 'o'. If you then typed 'o', you would only be able
+to type 'w'.
+
+In other words, C<-guarantee> ensures that you can only type in a valid input,
+and simply ignores any typing that would not lead to such an input.
+
+To help users get the input right, specifying C<-guarantee> as an array
+or hash reference also automatically specifies a
+L<< C<-complete> option|"Input autocompletion" >> with the array or hash
+as its completion list as well. So, whenever a C<-guarantee> is in
+effect, the user can usually autocomplete the acceptable inputs.
+
+Note, however, that C<-guarantee> can only reject (or autocomplete)
+input as it is typed if the Term::ReadKey module is available. If that
+module cannot be loaded, C<-guarantee> only applies its test after the
+C<< <ENTER>/<RETURN> >> key is pressed, and there will be no autocompletion
+available.
+
+=head4 Constraining input to numbers
+
+=over 4
+
+=item C<< -i >>
+
+=item C<< -integer [=> SPEC] >>
+
+=item C<< -n >>
+
+=item C<< -num[ber] [=> SPEC] >>
+
+=back
+
+If any of these options are specified, C<prompt()> will only accept a valid
+integer or number as input, and will reprompt until one is entered.
+
+If you need to restrict the kind of number further (say, to positive
+integers), you can supply an extra constraint as an argument to the
+long-form option. Any number entered must satisfy this constraint by
+successfully smart-matching it. For example:
+
+ $rep_count = prompt 'How many reps?', -integer => sub{ $_ > 0 };
+
+ $die_roll = prompt 'What did you roll?', -integer => [1..6];
+
+ $factor = prompt 'Prime factor:', -integer => \&is_prime;
+
+ $score = prompt 'Enter score:', -number => sub{ 0 <= $_ && $_ <= 100 };
+
+If the constraint is specified as a subroutine, the entered number will be
+passed to it both as its single argument and in C<$_>.
+
+You cannot pass a scalar value directly as a constraint, except those strings
+listed below. If you want a scalar value as a constraint, use a regex or
+array reference instead:
+
+ # Wrong...
+ $answer = prompt "What's the ultimate answer?",
+ -integer => 42;
+
+ # Use this instead...
+ $answer = prompt "What's the ultimate answer?",
+ -integer => qr/^42$/;
+
+ # Or this...
+ $answer = prompt "What's the ultimate answer?",
+ -integer => [42];
+
+
+Only the following strings may be passed directly as scalar value
+constraints. They do mot match exactly, but instead act as specifiers
+for one or more built-in constraints. You can also pass a string that
+contains two or more of them, separated by whitespace, in which case
+they must all be satisfied. The specifiers are:
+
+=over 4
+
+=item C<'pos'> or C<'positive'>
+
+The number must be greater than zero
+
+=item C<'neg'> or C<'negative'>
+
+The number must be less than zero
+
+=item C<'zero'>
+
+The number must be equal to zero
+
+=item C<'even'> or C<'odd'>
+
+The number must have the correct parity
+
+=back
+
+You can also prepend C<"non"> to any of the above to reverse their meaning.
+
+For example:
+
+ $rep_count = prompt 'How much do you bid?', -number => 'positive';
+
+ $step_value = prompt 'Next step:', -integer => 'even nonzero';
+
+
+=head4 Constraining input to filenames
+
+=over 4
+
+=item C<< -f >>
+
+=item C<< -filenames >>
+
+=back
+
+You can tell C<prompt()> to accept only valid filenames, using the
+C<-filenames> option (or its shortcut: C<-f>).
+
+This option is equivalent to the options:
+
+ -must => {
+ 'File must exist' => sub { -e },
+ 'File must be readable' => sub { -r },
+ },
+ -complete => 'filenames',
+
+In other words C<-filenames> requires C<prompt()> to accept only the name
+of an existing, readable file, and it also activates filename completion.
+
+
+=head4 Constraining input to "keyletters"
+
+=over
+
+=item C<< -k >>
+
+=item C<< -key[let[ter]][s] >>
+
+=back
+
+A common interaction is to offer the user a range of actions, each of
+which is specified by keying a unique letter, like so:
+
+ INPUT:
+ given (prompt '[S]ave, (R)evert, or (D)iscard:', -default=>'S') {
+ when (/R/i) { revert_file() }
+ when (/D/i) { discard_file() }
+ when (/S/i) { save_file() }
+ default { goto INPUT; }
+ }
+
+This can be cleaned up (very slightly) by using a guarantee:
+
+ given (prompt '[S]ave, (R)evert, or (D)iscard:', -default=>'S',
+ -guarantee=>qr/[SRD]/i
+ ) {
+ when (/R/i) { revert_file() }
+ when (/D/i) { discard_file() }
+ default { save_file() }
+ }
+
+However, it's still annoying to have to specify the three key letters
+twice (and the default choice three times) within the call to
+C<prompt()>. So IO::Prompter provides an option that extracts this
+information directly from the prompt itself:
+
+ given (prompt '[S]ave, (R)evert, or (D)iscard:', -keyletters) {
+ when (/R/i) { revert_file() }
+ when (/D/i) { discard_file() }
+ default { save_file() }
+ }
+
+This option scans the prompt string and extracts any purely alphanumeric
+character sequences that are enclosed in balanced brackets of any kind
+(square, angle, round, or curly). It then makes each of these character
+sequences a valid input (by implicitly setting the C<-guarantee>
+option), and adds the first option in square brackets (if any) as the
+C<-default> value of the prompt.
+
+Note that the key letters don't have to be at the start of a word, don't
+have to be a single character, and can be either upper or lower case.
+For example:
+
+ my $action = prompt -k, '(S)ave, Save(a)ll, (Ex)it without saving';
+
+Multi-character key letters are often a good choice for options with
+serious or irreversible consequences.
+
+A common idiom with key letters is to use the C<-single> option as well,
+so that pressing any key letter immediately completes the input, without
+the user having to also press C<< <ENTER>/<RETURN> >>:
+
+ given (prompt -k1, '[S]ave, (R)evert, or (D)iscard:') {
+ when (/R/i) { revert_file() }
+ when (/D/i) { discard_file() }
+ default { save_file() }
+ }
+
+
+
+=head3 Preserving terminal newlines
+
+=over 4
+
+=item C<< -l >>
+
+=item C<< -line >>
+
+=back
+
+The (encapsulated) string returned by C<prompt()> is automatically chomped by
+default. To prevent that chomping, specify this option.
+
+
+=head3 Constraining what can be returned
+
+=over 4
+
+=item C<< -must => HASHREF >>
+
+=back
+
+This option allows you to specify requirements and constraints on the input
+string that is returned by C<prompt()>. These limitations are specified as the
+values of a hash.
+
+If the C<-must> option is specified, once input is complete every value in the
+specified hash is smartmatched against the input text. If any of them fail to
+match, the input is discarded, the corresponding hash key is printed as an
+error message, and the prompt is repeated.
+
+Note that the values of the constraint hash cannot be single strings or
+numbers, except for certain strings (such as C<'pos'>, C<'nonzero'>, or
+C<'even'>, as described in L<"Constraining input to numbers">).
+
+If you want to constrain the input to a single string or number (a very
+unusual requirement), just place the value in an array, or match it
+with a regex:
+
+ # This doesn't work...
+ my $magic_word = prompt "What's the magic word?",
+ -must => { 'be polite' => 'please' };
+
+ # Use this instead...
+ my $magic_word = prompt "What's the magic word?",
+ -must => { 'be polite' => ['please'] };
+
+ # Or, better still...
+ my $magic_word = prompt "What's the magic word?",
+ -must => { 'be polite' => qr/please/i };
+
+
+The C<-must> option allows you to test inputs against multiple
+conditions and have the appropriate error messages for each displayed.
+It also ensures that, when C<prompt()> eventually returns, you are
+guaranteed that the input meets all the specified conditions.
+
+For example, suppose the user is required to enter a positive odd prime
+number less than 100. You could enforce that with:
+
+ my $opnlt100 = prompt 'Enter your guess:',
+ -integer,
+ -must => { 'be odd' => 'odd',
+ 'be in range' => [1..100],
+ 'It must also be prime:' => \&isprime,
+ };
+
+Note that, if the error message begins with anything except an uppercase
+character, the prompt is reissued followed by the error message in
+parentheses with the word "must" prepended (where appropriate).
+Otherwise, if the error message does start with an uppercase character,
+the prompt is not reissued and the error message is printed verbatim. So
+a typical input sequence for the previous example might look like:
+
+ Enter your guess: 101
+ Enter your guess: (must be in range) 42
+ It must also be prime: 2
+ Enter your guess: (must be odd) 7
+
+at which point, the call to C<prompt()> would accept the input and return.
+
+See also L<the C<-guarantee> option|"Constraining what can be typed">,
+which allows you to constrain inputs as they are typed, rather than
+after they are entered.
+
+
+=head3 Changing how returns are echoed
+
+=over 4
+
+=item C<< -r[STR] >>
+
+=item C<< -ret[urn] [=> STR] >>
+
+=back
+
+When C<< <ENTER>/<RETURN> >> is pressed, C<prompt()> usually echoes a carriage return.
+However, if this option is given, C<prompt()> echoes the specified string
+instead. If the string is omitted, it defaults to C<"\n">.
+
+For example:
+
+ while (1) {
+ my $expr = prompt 'Calculate:', -ret=>' = ';
+ say evaluate($expr);
+ }
+
+would prompt for something like this:
+
+ Calculate: 2*3+4^5_
+
+and when the C<< <ENTER>/<RETURN> >> key is pressed, respond with:
+
+ Calculate: 2*3+4^5 = 1030
+ Calculate: _
+
+The string specified with C<-return> is also automatically echoed if the
+L<< C<-single> option|"Single-character input" >> is used. So if you
+don't want the automatic carriage return that C<-single> mode supplies,
+specify C<< -return=>"" >>.
+
+
+=head3 Single-character input
+
+=over 4
+
+=item C<< -s >>
+
+=item C<< -1 >>
+
+=item C<< -sing[le] >>
+
+=back
+
+This option causes C<prompt()> to return immediately once any single
+character is input. The user does not have to push the C<< <ENTER>/<RETURN> >>
+key to complete the input operation. C<-single> mode input is only
+available if the Term::ReadKey module can be loaded.
+
+By default, C<prompt()> echoes the single character that is entered. Use
+the L<C<-echo> option|"Specifying what to echo on input"> to change or
+prevent that.
+
+ # Let user navigate through maze by single, silent keypresses...
+ while ($nextdir = prompt "\n", -single, -echo, -guarantee=>qr/[nsew]/) {
+ move_player($nextdir);
+ }
+
+Unless echoing has been disabled, by default C<prompt()> also supplies a
+carriage return after the input character. Use
+L<the C<-return> option|"Changing how returns are echoed"> to change
+that behaviour. For example, this:
+
+ my $question = <<END_QUESTION;
+ Bast is the goddess of: (a) dogs (b) cats (c) cooking (d) war?
+ Your answer:
+ END_QUESTION
+
+ my $response = prompt $question, -1, -return=>' is ', -g=>['a'..'d'];
+ say $response eq $answer ? 'CORRECT' : 'incorrect';
+
+prompts like this:
+
+ Bast is the goddess of: (a) dogs (b) cats (c) cooking (d) war?
+ Your answer: _
+
+accepts a single character, like so:
+
+ Bast is the goddess of: (a) dogs (b) cats (c) cooking (d) war?
+ Your answer: b_
+
+and completes the line thus:
+
+ Bast is the goddess of: (a) dogs (b) cats (c) cooking (d) war?
+ Your answer: b is CORRECT
+ _
+
+
+=head3 Returning raw data
+
+=over 4
+
+=item C<< -v >>
+
+=item C<< -verb[atim] >>
+
+=back
+
+Normally, C<prompt()> returns a special object that contains the text
+input, the success value, and other information such as whether the
+default was selected and whether the input operation timed out.
+
+However, if you prefer to have C<prompt()> just return the input text string
+directly, you can specify this option.
+
+Note however that, under C<-verbatim>, the input is still
+autochomped (unless you also specify
+L<the C<-line> option|"Preserving terminal newlines">.
+
+
+=head3 Prompting on a clear screen
+
+=over 4
+
+=item C<< -w >>
+
+=item C<< -wipe[first] >>
+
+=back
+
+If this option is present, C<prompt()> prints 1000 newlines before
+printing its prompt, effectively wiping the screen clear of other text.
+
+If the C<-wipefirst> variant is used, the wipe will only occur if the
+particular call to C<prompt()> is the first such call anywhere in your
+program. This is useful if you'd like the screen cleared at the start of
+input only, but you're not sure which call to C<prompt()> will happen
+first: just use C<-wipefirst> on all possible initial calls and only the
+actual first call will wipe the screen.
+
+
+=head3 Requesting confirmations
+
+=over 4
+
+=item C<< -y[n] >> or C<< -Y[N] >>
+
+=item C<< -yes[no] >> or C<< -Yes[No] >>
+
+=item C<< -yes[no] => COUNT >> or C<< -Yes[No] => COUNT >>
+
+=back
+
+This option invokes a special mode that can be used to confirm (or deny)
+something. If one of these options is specified, C<prompt> still
+returns the user's input, but the success or failure of the object returned
+now depends on what the user types in.
+
+A true result is returned if C<'y'> is the first character entered. If
+the flag includes an C<n> or C<N>, a false result is returned if C<'n'>
+is the first character entered (and any other input causes the prompt to
+be reissued). If the option doesn't contain an C<n> or C<N>, any input
+except C<'y'> is treated as a "no" and a false value is returned.
+
+If the option is capitalized (C<-Y> or C<-YN>), the first letter of the
+input must be likewise a capital (this is a handy means of slowing down
+automatic unthinking C<y>..."Oh no!" responses to potentially serious
+decisions).
+
+This option is most often used in conjunction with the C<-single> option, like
+so:
+
+ $continue = prompt("Continue? ", -yn1);
+
+so that the user can just hit C<y> or C<n> to continue, without having to hit
+C<< <ENTER>/<RETURN> >> as well.
+
+If the optional I<COUNT> argument is supplied, the prompting is repeated
+that many times, with increasingly insistent requests for confirmation.
+The answer must be "yes" in each case for the final result to be true.
+For example:
+
+ $rm_star = prompt("Do you want to delete all files? ", -Yes=>3 );
+
+might prompt:
+
+ Do you want to delete all files? Y
+ Really? Y
+ Are you sure? Y
+
+
+
+=head3 Bundling short-form options
+
+You can bundle together any number of short-form options, including those that
+take string arguments. For example, instead of writing:
+
+ if (prompt "Continue? ", -yes, -1, -t10, -dn) {
+
+you could just write:
+
+ if (prompt "Continue? ", -y1t10dn) {...}
+
+This often does I<not> improve readability (as the preceding example
+demonstrates), but is handy for common usages such as C<-y1> ("ask for
+confirmation, don't require an C<< <ENTER>/<RETURN> >>) or C<-vl>
+("Return a verbatim and unchomped string").
+
+
+=head3 Escaping otherwise-magic options
+
+=over 4
+
+C<< -_ >>
+
+=back
+
+The C<-_> option exists only to be an explicit no-op. It allows you to
+specify short-form options that would otherwise be interpreted as Perl
+file operators or other special constructs, simply by prepending or
+appending a C<_> to them. For example:
+
+ my $input
+ = prompt -l_; # option -l, not the -l file operator.
+
+The following single-letter options require an underscore to chaperone them
+when they're on their own: C<-e>, C<-l>, C<-r>, C<-s>, C<-w>, and C<-y>.
+However, an underscore is not required if two or more are bundled together.
+
+
+=head2 Useful useless uses of C<prompt()>
+
+Normally, in a void context, a call to C<prompt()> issues a warning that
+you are doing an input operation whose input is immediately thrown away.
+
+There is, however, one situation where this useless use of C<prompt()> in a
+void context is actually useful:
+
+ say $data;
+ prompt('END OF DATA. Press any key to exit', -echo, -single);
+ exit;
+
+Here, we're using prompt simply to pause the application after the data is
+printed. It doesn't matter what the user types in; the typing itself is the
+message (and the message is "move along").
+
+In such cases, the "useless use..." warning can be suppressed using the
+C<< -void >> option:
+
+ say $data;
+ prompt('END OF DATA. Press any key to exit', -echo, -single, -void);
+ exit;
+
+
+=head2 Simulating input
+
+IO::Prompter provides a mechanism with which you can "script" a sequence of
+inputs to an application. This is particularly useful when demonstrating
+software during a presentation, as you do not have to remember what to type,
+or concentrate on typing at all.
+
+If you pass a string as an argument to C<use IO::Prompter>, the
+individual lines of that string are used as successive input lines to
+any call to C<prompt()>. So for example, you could specify several sets
+of input data, like so:
+
+ use IO::Prompter <<END_DATA
+ Leslie
+ 45
+ 165
+ Jessie
+ 28
+ 178
+ Dana
+ 12
+ 120
+ END_DATA
+
+and then read this data in an input loop:
+
+ while (my $name = prompt 'Name:') {
+ my $age = prompt 'Age:';
+ my $height = prompt 'Height:';
+
+ process($name, $age, $height);
+ }
+
+Because the C<use IO::Prompter> supplies input data,
+the three calls to C<prompt()> will no longer read
+data from C<*ARGV>. Instead they will read it from
+the supplied input data.
+
+Moreover, each call to C<prompt()> will simulate the typing-in process
+automatically. That is, C<prompt()> uses a special input mode where,
+each time you press a keyboard letter, it echoes not that character, but
+rather the next character from the specified input. The effect is that
+you can just type on the keyboard at random, but have the correct input
+appear. This greatly increases the convincingness of the simulation.
+
+If at any point, you hit C<< <ENTER>/<RETURN> >> on the keyboard, C<prompt()>
+finishes typing in the input for you (using a realistic typing speed),
+and returns the input string. So you can also just hit C<< <ENTER>/<RETURN> >>
+when the prompt first appears, to have the entire line of input typed
+for you.
+
+Alternatively, if you hit C<< <ESC> >> at any point, C<prompt()> escapes
+from the simulated input mode for that particular call to C<prompt()>,
+and allows you to (temporarily) type text in directly. If you enter only
+a single C<< <ESC> >>, then C<prompt()> throws away the current line of
+simulated input; if you enter two C<< <ESC> >>'s, the simulated input is
+merely deferred to the next call to C<prompt()>.
+
+All these keyboard behaviours require the Term::ReadKey module to be
+available. If it isn't, C<prompt()> falls back on a simpler simulation,
+where it just autotypes each entire line for you and pauses at the
+end of the line, waiting for you to hit C<< <ENTER>/<RETURN> >> manually.
+
+Note that any line of the simulated input that begins with
+a <CTRL-D> or <CTRL-Z> is treated as an input failure (just as
+if you'd typed that character as input).
+
+=head1 DIAGNOSTICS
+
+All non-fatal diagnostics can be disabled using a C<no warnings> with the
+appropriate category.
+
+=over
+
+=item C<< prompt(): Can't open *ARGV: %s >>
+
+(F) By default, C<prompt()> attempts to read input from
+ the C<*ARGV> filehandle. However, it failed to open
+ that filehandle. The reason is specified at the end of
+ the message.
+
+
+=item C<< prompt(): Missing value for %s (expected %s) >>
+
+(F) A named option that requires an argument was specified,
+ but no argument was provided after the option. See
+ L<"Summary of options">.
+
+
+=item C<< prompt(): Invalid value for %s (expected %s) >>
+
+(F) The named option specified expects an particular type
+ of argument, but found one of an incompatible type
+ instead. See L<"Summary of options">.
+
+
+=item C<< prompt(): Unknown option %s ignored >>
+
+(W misc) C<prompt()> was passed a string starting with
+ a hyphen, but could not parse that string as a
+ valid option. The option may have been misspelt.
+ Alternatively, if the string was supposed to be
+ (part of) the prompt, it will be necessary to use
+ L<the C<-prompt> option|"Specifying what to
+ prompt"> to specify it.
+
+
+=item C<< prompt(): Unexpected argument (% ref) ignored >>
+
+(W reserved) C<prompt()> was passed a reference to
+ an array or hash or subroutine in a position
+ where an option flag or a prompt string was
+ expected. This may indicate that a string
+ variable in the argument list didn't contain
+ what was expected, or a reference variable was
+ not properly dereferenced. Alternatively, the
+ argument may have been intended as the
+ argument to an option, but has become
+ separated from it somehow, or perhaps the
+ option was deleted without removing the
+ argument as well.
+
+
+=item C<< Useless use of prompt() in void context >>
+
+(W void) C<prompt()> was called but its return value was
+ not stored or used in any way. Since the
+ subroutine has no side effects in void context,
+ calling it this way achieves nothing. Either make
+ use of the return value directly or, if the usage
+ is deliberate, put a C<scalar> in front of the
+ call to remove the void context.
+
+
+=item C<< prompt(): -default value does not satisfy -must constraints >>
+
+(W misc) The C<-must> flag was used to specify one or more
+ input constraints. The C<-default> flag was also
+ specified. Unfortunately, the default value
+ provided did not satisfy the requirements
+ specified by the C<-must> flag. The call to
+ C<prompt()> will still go ahead (after issuing the
+ warning), but the default value will never be
+ returned, since the constraint check will reject
+ it. It is probably better simply to include the
+ default value in the list of constraints.
+
+
+=item C<< prompt(): -keyletters found too many defaults >>
+
+(W ambiguous) The C<-keyletters> option was specified,
+ but analysis of the prompt revealed two or
+ more character sequences enclosed in square
+ brackets. Since such sequences are taken to
+ indicate a default value, having two or more
+ makes the default ambiguous. The prompt
+ should be rewritten with no more than one set
+ of square brackets.
+
+
+=item C<< Warning: next input will be in plaintext >>
+
+(W bareword) The C<prompt()> subroutine was called with
+ the C<-echo> flag, but the Term::ReadKey
+ module was not available to implement this
+ feature. The input will proceed as normal, but
+ this warning is issued to ensure that the user
+ doesn't type in something secret, expecting it
+ to remain hidden, which it won't.
+
+
+=item C<< prompt(): Too many menu items. Ignoring the final %d >>
+
+(W misc) A C<-menu> was specified with more than 52 choices.
+ Because, by default, menus use upper and lower-
+ case alphabetic characters as their selectors,
+ there were no available selectors for the extra
+ items after the first 52. Either reduce the number
+ of choices to 52 or less, or else add the
+ C<-number> option to use numeric selectors instead.
+
+=back
+
+
+=head1 CONFIGURATION AND ENVIRONMENT
+
+IO::Prompter can be configured by setting any of the following
+environment variables:
+
+=over
+
+=item C<$IO_PROMPTER_COMPLETE_KEY>
+
+Specifies the key used to initiate
+L<user-specified completions|"Input autocompletion">.
+Defaults to <TAB>
+
+=item C<$IO_PROMPTER_HISTORY_KEY>
+
+Specifies the key used to initiate
+L<history completions|"Completing from your input history">.
+Defaults to <CTRL-R>
+
+=item C<$IO_PROMPTER_COMPLETE_MODES>
+
+Specifies the
+L<response sequence|"Configuring the autocompletion interaction">
+for user-defined completions. Defaults to C<'list+longest full'>
+
+=item C<$IO_PROMPTER_HISTORY_MODES>
+
+Specifies the
+L<response sequence|"Configuring the autocompletion interaction">
+for history completions. Defaults to C<'full'>.
+
+=back
+
+
+=head1 DEPENDENCIES
+
+Requires the Contextual::Return module.
+
+The module also works much better if Term::ReadKey is available
+(though this is not essential).
+
+
+=head1 INCOMPATIBILITIES
+
+This module does not play well with Moose (or more specifically, with
+Moose::Exporter) because both of them try to play sneaky games with
+Scalar::Util::blessed.
+
+The current solution is to make sure that you load Moose before
+loading IO::Prompter. Even just doing this:
+
+ use Moose ();
+ use IO::Prompter;
+
+is sufficient.
+
+
+=head1 BUGS AND LIMITATIONS
+
+No unresolved bugs have been reported.
+
+Please report any bugs or feature requests to
+C<bug-io-prompter@rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org>.
+
+
+=head1 AUTHOR
+
+Damian Conway C<< <DCONWAY@CPAN.org> >>
+
+
+=head1 LICENCE AND COPYRIGHT
+
+Copyright (c) 2009, Damian Conway C<< <DCONWAY@CPAN.org> >>.
+All rights reserved.
+
+This module is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself. See L<perlartistic>.
+
+
+=head1 DISCLAIMER OF WARRANTY
+
+BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
+EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
+ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
+YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
+NECESSARY SERVICING, REPAIR, OR CORRECTION.
+
+IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
+LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
+OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
+THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
+RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
+FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
+SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGES.
diff --git a/t/00.load.t b/t/00.load.t
new file mode 100644
index 0000000..ee8a1fb
--- /dev/null
+++ b/t/00.load.t
@@ -0,0 +1,10 @@
+use 5.010;
+use warnings;
+
+use Test::More tests => 1;
+
+BEGIN {
+ use_ok( 'IO::Prompter' );
+}
+
+diag( "Testing IO::Prompter $IO::Prompter::VERSION" );
diff --git a/t/argv.t b/t/argv.t
new file mode 100644
index 0000000..9be410c
--- /dev/null
+++ b/t/argv.t
@@ -0,0 +1,26 @@
+use 5.010;
+use warnings;
+use Test::More 'no_plan';
+
+use IO::Prompter;
+
+my @expected = (
+ 'arg1',
+ 'arg 2',
+ 'arg 3',
+ 4,
+ 5,
+);
+
+my $argv_source = q{ arg1 'arg 2' "arg 3" "4" 5 };
+open my $fh, '<', \$argv_source;
+
+$_ = 'UNDERBAR';
+if (prompt -argv, -in=>$fh, 'ARGV: ') {
+ is_deeply \@ARGV, \@expected => '@ARGV set';
+ is $_, 'UNDERBAR' => 'Left $_ alone'
+}
+else {
+ fail '@ARGV set';
+}
+
diff --git a/t/autoexport.t b/t/autoexport.t
new file mode 100644
index 0000000..aa44b9d
--- /dev/null
+++ b/t/autoexport.t
@@ -0,0 +1,27 @@
+use Test::More;
+
+use IO::Prompter { ask => [-yn1, -verbatim] };
+
+{
+ open my $in_fh, '<', \'y' or die;
+ my $response = ask(-in=>$in_fh);
+ is $response, 'y' => 'Ask matched on single y';
+ ok !ref($response) => 'Verbatim';
+}
+
+{
+ use IO::Prompter { ask => [-yn1] };
+ open my $in_fh, '<', \'y' or die;
+ my $response = ask(-in=>$in_fh);
+ is $response, 'y' => 'Ask matched on single y';
+ ok ref($response) => 'Not verbatim';
+}
+
+{
+ open my $in_fh, '<', \'y' or die;
+ my $response = ask(-in=>$in_fh);
+ is $response, 'y' => 'Ask matched on single y';
+ ok !ref($response) => 'Verbatim';
+}
+
+done_testing();
diff --git a/t/bundled.t b/t/bundled.t
new file mode 100644
index 0000000..c8eba9f
--- /dev/null
+++ b/t/bundled.t
@@ -0,0 +1,15 @@
+use 5.010;
+use warnings;
+use Test::More 'no_plan';
+
+use IO::Prompter;
+
+local *ARGV;
+open *ARGV, '<', \<<END_INPUT or die $!;
+Line 1
+Line 2
+END_INPUT
+
+my $result = prompt "Enter line 1", -lt0v;
+is $result, "Line 1\n" => '-l effective';
+ok !ref($result) => '-v effective';
diff --git a/t/default.t b/t/default.t
new file mode 100644
index 0000000..6066e7b
--- /dev/null
+++ b/t/default.t
@@ -0,0 +1,42 @@
+use 5.010;
+use warnings;
+use Test::More 'no_plan';
+
+use IO::Prompter;
+
+local *ARGV;
+open *ARGV, '<', \<<END_INPUT or die $!;
+
+Non-default
+
+
+END_INPUT
+
+if (prompt "Enter line 1", -default=>'foo' ) {
+ is $_, 'foo' => 'First default used';
+}
+else {
+ fail 'First default used';
+}
+
+if (prompt "Enter line 1", -default=>'foo' ) {
+ is $_, 'Non-default' => 'First non-default';
+}
+else {
+ fail 'First non-default';
+}
+
+if (prompt "Enter line 1", -dFOO ) {
+ is $_, 'FOO' => '-d default';
+}
+else {
+ fail '-d default';
+}
+
+if (prompt "Enter line 1", -number, -menu=>[1..10], -default=>'foo' ) {
+ is $_, 'foo' => '-menu default';
+}
+else {
+ fail '-menu non-default';
+}
+
diff --git a/t/errors.t b/t/errors.t
new file mode 100644
index 0000000..d1e5b6d
--- /dev/null
+++ b/t/errors.t
@@ -0,0 +1,84 @@
+#use 5.010;
+use warnings;
+use Test::More 'no_plan';
+
+use IO::Prompter;
+
+eval { my $val = prompt "Enter line 1", -timeout };
+like $@, qr/prompt\(\): Missing value for -timeout \(expected number of seconds\)/
+ => '-timeout missing value exception';
+
+eval { my $val = prompt "Enter line 1", -timeout=>'yes' };
+like $@, qr/prompt\(\): Invalid value for -timeout \(expected number of seconds\)/
+ => '-timeout invalid value exception';
+
+
+{
+ my $warned;
+ local $SIG{__WARN__} = sub {
+ my ($warning) = @_;
+ like $warning, qr/\AUseless use of prompt\(\) in void context/
+ => 'void context warning';
+ $warned = 1;
+ };
+
+ my $input = 'text';
+ open my $fh, '<', \$input or die $!;
+ prompt "Enter line 1", -in=>$fh;
+ fail 'void context warning' if !$warned;
+}
+
+
+{
+ no warnings 'void';
+ my $warned;
+ local $SIG{__WARN__} = sub {
+ $warned = 1;
+ };
+
+ my $input = 'text';
+ open my $fh, '<', \$input or die $!;
+ prompt "Enter line 1", -in=>$fh;
+ ok !$warned => 'muffled void context warning';
+}
+
+{
+ my $warned;
+ local $SIG{__WARN__} = sub {
+ $warned = 1;
+ };
+
+ my $input = 'text';
+ open my $fh, '<', \$input or die $!;
+ prompt "Enter line 1", -in=>$fh, -void;
+ ok !$warned => 'turned off void context warning with -void';
+}
+
+{
+ my $warned;
+ local $SIG{__WARN__} = sub {
+ my ($warning) = @_;
+ like $warning, qr/\Aprompt\(\): Unknown option -zen ignored/
+ => 'Unknown option warning';
+ $warned = 1;
+ };
+
+ my $input = 'text';
+ open my $fh, '<', \$input or die $!;
+ my $result = prompt "Enter line 1", -in=>$fh, -zen;
+ fail 'unknown option warning' if !$warned;
+}
+
+{
+ my $warned;
+ local $SIG{__WARN__} = sub {
+ $warned = 1;
+ };
+
+ my $input = 'text';
+ open my $fh, '<', \$input;
+ no warnings 'misc';
+ my $result = prompt "Enter line 1", -in=>$fh, -foobar;
+ ok !$warned => 'muffled unknown option warning';
+}
+
diff --git a/t/fail.t b/t/fail.t
new file mode 100644
index 0000000..01b967a
--- /dev/null
+++ b/t/fail.t
@@ -0,0 +1,37 @@
+use 5.010;
+use warnings;
+use Test::More 'no_plan';
+
+use IO::Prompter;
+
+local *ARGV;
+open *ARGV, '<', \<<END_INPUT or die $!;
+Line 1
+Loser!
+42
+END_INPUT
+
+if (prompt -fail=>'Loser!', "Enter line 1") {
+ is $_, 'Line 1' => 'First line retrieved';
+}
+else {
+ fail 'First line retrieved';
+}
+
+if (prompt -fail=>'Loser!', "Enter line 2") {
+ fail 'Failure condition met';
+}
+else {
+ pass 'Failure condition met';
+ ok !$_ => 'Correctly returned false';
+}
+
+if (prompt -fail=>[41..43] , "Enter line 2") {
+ fail 'Second failure condition met';
+}
+else {
+ pass 'Second failure condition met';
+ ok !$_ => 'Correctly returned false';
+}
+
+
diff --git a/t/fake.t b/t/fake.t
new file mode 100644
index 0000000..15c6f79
--- /dev/null
+++ b/t/fake.t
@@ -0,0 +1,35 @@
+use 5.010;
+use warnings;
+use Test::More 'no_plan';
+
+use IO::Prompter;
+
+local *ARGV;
+open *ARGV, '<', \<<END_INPUT or die $!;
+
+
+END_INPUT
+
+if (prompt -out=>\*STDERR, "Enter line 1: ") {
+ is $_, 'Line 1' => 'First line retrieved';
+}
+else {
+ fail 'First line retrieved';
+}
+
+$_ = 'UNDERBAR';
+if (my $input = prompt -out=>\*STDERR, "Enter line 2: ") {
+ is $input, 'Line 2' => 'Second line retrieved';
+ is $_, 'UNDERBAR' => 'Second line left $_ alone'
+}
+else {
+ fail 'Second line retrieved';
+}
+
+
+
+use IO::Prompter <<END_DATA;
+Line 1
+Line 2
+END_DATA
+
diff --git a/t/fake_no_term_readkey.t b/t/fake_no_term_readkey.t
new file mode 100644
index 0000000..c134c46
--- /dev/null
+++ b/t/fake_no_term_readkey.t
@@ -0,0 +1,36 @@
+use lib qw< slib >;
+use 5.010;
+use warnings;
+use Test::More 'no_plan';
+
+use IO::Prompter;
+
+local *ARGV;
+open *ARGV, '<', \<<END_INPUT or die $!;
+
+
+END_INPUT
+
+if (prompt -out=>\*STDERR, "Enter line 1: ") {
+ is $_, 'Line 1' => 'First line retrieved';
+}
+else {
+ fail 'First line retrieved';
+}
+
+$_ = 'UNDERBAR';
+if (my $input = prompt -out=>\*STDERR, "Enter line 2: ") {
+ is $input, 'Line 2' => 'Second line retrieved';
+ is $_, 'UNDERBAR' => 'Second line left $_ alone'
+}
+else {
+ fail 'Second line retrieved';
+}
+
+
+
+use IO::Prompter <<END_DATA;
+Line 1
+Line 2
+END_DATA
+
diff --git a/t/filehandles.t b/t/filehandles.t
new file mode 100644
index 0000000..f938e97
--- /dev/null
+++ b/t/filehandles.t
@@ -0,0 +1,36 @@
+use 5.010;
+use warnings;
+use Test::More 'no_plan';
+
+use IO::Prompter;
+
+open my $in_fh, '<', \<<END_INPUT or die $!;
+Line 1
+Line 2
+END_INPUT
+
+my $output = q{};
+open my $out_fh, '>', \$output or die $!;
+
+if (prompt "Enter line 1", -in=>$in_fh, -out=>$out_fh) {
+ is $_, 'Line 1' => 'First line retrieved';
+ is $output, q{} => 'No prompt';
+}
+else {
+ fail 'First line retrieved';
+}
+
+$output = q{};
+$out_fh = undef;
+open $out_fh, '>', \$output or die $!;
+
+$_ = 'UNDERBAR';
+if (my $input = prompt "Enter line 2", -in=>$in_fh, -out=>$out_fh) {
+ is $input, 'Line 2' => 'Second line retrieved';
+ is $output, q{} => 'No prompt';
+ is $_, 'UNDERBAR' => 'Second line left $_ alone'
+}
+else {
+ fail 'Second line retrieved';
+}
+
diff --git a/t/guarantee.t b/t/guarantee.t
new file mode 100644
index 0000000..1169fcb
--- /dev/null
+++ b/t/guarantee.t
@@ -0,0 +1,47 @@
+use 5.010;
+use warnings;
+use Test::More 'no_plan';
+
+use IO::Prompter;
+
+local *ARGV;
+open *ARGV, '<', \<<END_INPUT or die $!;
+N
+Y
+z
+
+ex
+END_INPUT
+
+if (prompt "(y)o or ba(z)", -guarantee=>qr/[yz]/i) {
+ is $_, 'Y' => 'First guaranteed input retrieved';
+}
+else {
+ fail 'First guaranteed input retrieved';
+}
+
+
+if (prompt "e(y)e or (z)en", -gaurenty=>['y','z']) {
+ is $_, 'z' => 'Second guaranteed input retrieved';
+}
+else {
+ fail 'Second guaranteed input retrieved';
+}
+
+
+
+if (prompt "(ex)it, [y]up or (z)en", -g=>{ex=>1, y=>1, z=>1}, -dy) {
+ is $_, 'y' => 'Default guaranteed input retrieved';
+}
+else {
+ fail 'Default guaranteed input retrieved';
+}
+
+if (prompt "(ex)it, [y]up or (z)en", -g=>{ex=>1, y=>1, z=>1}) {
+ is $_, 'ex' => 'Multi-character guaranteed input retrieved';
+}
+else {
+ fail 'Multi-character guaranteed input retrieved';
+}
+
+
diff --git a/t/integer.t b/t/integer.t
new file mode 100644
index 0000000..75a9088
--- /dev/null
+++ b/t/integer.t
@@ -0,0 +1,51 @@
+use 5.010;
+use warnings;
+use Test::More 'no_plan';
+
+use IO::Prompter;
+
+local *ARGV;
+open *ARGV, '<', \<<END_INPUT or die $!;
+1
+a
+b
+-2234
+-1
+0
+2
+1
+3
+5
+177
+END_INPUT
+
+if (prompt -integer, "Enter an integer: ") {
+ like $_, qr/^\s*[+-]?\d++\s*/ => 'First line retrieved';
+}
+else {
+ fail 'First line retrieved';
+}
+
+$_ = 'UNDERBAR';
+if (my $input = prompt -i, "Enter another integer: ") {
+ like $input, qr/^\s*[+-]?\d++\s*/ => 'Second line retrieved';
+ is $_, 'UNDERBAR' => 'Second line left $_ alone';
+}
+else {
+ fail 'Second line retrieved';
+}
+
+if (prompt -integer=>'pos odd', "Enter an integer: ") {
+ is $_, 1 => 'Constrained line retrieved';
+}
+else {
+ fail 'Constrained line retrieved';
+}
+
+if (prompt -integer=>qr/7/, "Enter an integer: ") {
+ is $_, 177 => 'Constrained line 2 retrieved';
+}
+else {
+ fail 'Constrained line 2 retrieved';
+}
+
diff --git a/t/interactive.t b/t/interactive.t
new file mode 100644
index 0000000..24344d8
--- /dev/null
+++ b/t/interactive.t
@@ -0,0 +1,37 @@
+use 5.010;
+use warnings;
+use Test::More;
+
+use IO::Prompter;
+
+if (!-t *STDIN || !-t *STDERR) {
+ plan('skip_all' => 'Non-interactive test environment');
+}
+else {
+ plan('no_plan');
+}
+
+select *STDERR;
+
+my %ok = (
+ 'Pure prompt' => 0,
+ 'Assignment prompt' => 0,
+ '$_ unaffected' => 0,
+);
+
+say {STDERR} q{};
+
+if (prompt -in=>*STDIN, -i, "\tEnter an integer: ") {
+ $ok{'Pure prompt'} = m{ ^ \s* [+-]? \d++ \s* $ }x;
+}
+
+$_ = 'UNDERBAR';
+if (my $input = prompt -i, -prompt=>"\tEnter another integer: ") {
+ $ok{'Assignment prompt'} = $input =~ m{ ^ \s* [+-]? \d++ \s* $ }x;
+ $ok{'$_ unaffected'} = $_ eq 'UNDERBAR';
+}
+
+for my $test (keys %ok) {
+ ok $ok{$test} => $test;
+}
+
diff --git a/t/interactive_echo.t b/t/interactive_echo.t
new file mode 100644
index 0000000..d2c2442
--- /dev/null
+++ b/t/interactive_echo.t
@@ -0,0 +1,52 @@
+use 5.010;
+use warnings;
+use Test::More;
+use diagnostics;
+
+use IO::Prompter;
+
+if (!-t *STDIN || !-t *STDERR) {
+ plan('skip_all' => 'Non-interactive test environment');
+}
+elsif (!eval { require Term::ReadKey }) {
+ plan('skip_all' => 'Term::ReadKey not available');
+ exit;
+}
+else {
+ plan('no_plan');
+}
+
+my %ok = (
+ 'Pure prompt' => 0,
+ 'Assignment prompt' => 0,
+ '$_ unaffected' => 0,
+ 'Dynamic echo' => 0,
+);
+
+if (prompt -i, "\n\tEnter an integer (should echo stars): ",
+ -echo=>'*',
+ -out=>\*STDERR
+) {
+ $ok{'Pure prompt'} = m{ ^ \s* [+-]? \d++ \s* $ }x;
+}
+
+$_ = 'UNDERBAR';
+if (my $input = prompt "\tEnter an integer (should echo nothing): ", -i, -_e, -out=>\*STDERR) {
+ $ok{'Assignment prompt'} = $input =~ m{ ^ \s* [+-]? \d++ \s* $ }x;
+ $ok{'$_ unaffected'} = $_ eq 'UNDERBAR';
+}
+
+if (prompt "\tEnter your name (SHouLD eCHo iN HoSTaGe CaSe): ",
+ -echo => sub{ /[aeiou]/i ? lc : uc },
+ -out=>\*STDERR
+) {
+ $ok{'Dynamic echo'} = 1;
+}
+
+
+
+for my $test (keys %ok) {
+ ok $ok{$test} => $test;
+}
+
+
diff --git a/t/interactive_no_term_readkey.t b/t/interactive_no_term_readkey.t
new file mode 100644
index 0000000..83edc8f
--- /dev/null
+++ b/t/interactive_no_term_readkey.t
@@ -0,0 +1,40 @@
+
+use lib qw< slib >;
+
+use 5.010;
+use warnings;
+use Test::More;
+
+use IO::Prompter;
+
+if (!-t *STDIN || !-t *STDERR) {
+ plan('skip_all' => 'Non-interactive test environment');
+}
+else {
+ plan('no_plan');
+}
+
+select *STDERR;
+
+my %ok = (
+ 'Pure prompt' => 0,
+ 'Assignment prompt' => 0,
+ '$_ unaffected' => 0,
+);
+
+say {STDERR} q{};
+
+if (prompt -i, "\tEnter an integer: ") {
+ $ok{'Pure prompt'} = m{ ^ \s* [+-]? \d++ \s* $ }x;
+}
+
+$_ = 'UNDERBAR';
+if (my $input = prompt -i, "\tEnter another integer: ") {
+ $ok{'Assignment prompt'} = $input =~ m{ ^ \s* [+-]? \d++ \s* $ }x;
+ $ok{'$_ unaffected'} = $_ eq 'UNDERBAR';
+}
+
+for my $test (keys %ok) {
+ ok $ok{$test} => $test;
+}
+
diff --git a/t/interactive_out.t b/t/interactive_out.t
new file mode 100644
index 0000000..b867371
--- /dev/null
+++ b/t/interactive_out.t
@@ -0,0 +1,34 @@
+use 5.010;
+use warnings;
+use Test::More;
+
+use IO::Prompter;
+
+if (!-t *STDIN || !-t *STDERR) {
+ plan('skip_all' => 'Non-interactive test environment');
+}
+else {
+ plan('no_plan');
+}
+
+my %ok = (
+ 'Pure prompt' => 0,
+ 'Assignment prompt' => 0,
+ '$_ unaffected' => 0,
+);
+
+if (prompt -i, "\n\tEnter an integer: ", -out=>\*STDERR) {
+ $ok{'Pure prompt'} = m{ ^ \s* [+-]? \d++ \s* $ }x;
+}
+
+$_ = 'UNDERBAR';
+if (my $input = prompt -i, "\tEnter another integer: ", -out=>\*STDERR) {
+ $ok{'Assignment prompt'} = $input =~ m{ ^ \s* [+-]? \d++ \s* $ }x;
+ $ok{'$_ unaffected'} = $_ eq 'UNDERBAR';
+}
+
+for my $test (keys %ok) {
+ ok $ok{$test} => $test;
+}
+
+
diff --git a/t/interactive_return.t b/t/interactive_return.t
new file mode 100644
index 0000000..4992a7e
--- /dev/null
+++ b/t/interactive_return.t
@@ -0,0 +1,36 @@
+use 5.010;
+use warnings;
+use Test::More;
+use diagnostics;
+
+use IO::Prompter;
+
+if (!-t *STDIN || !-t *STDERR) {
+ plan('skip_all' => 'Non-interactive test environment');
+}
+else {
+ plan('no_plan');
+}
+
+my %ok = (
+ 'Pure prompt' => 0,
+ 'Assignment prompt' => 0,
+ '$_ unaffected' => 0,
+);
+
+if (prompt -i, "\n\tEnter an integer: ", -ret=>q{}, -out=>\*STDERR) {
+ $ok{'Pure prompt'} = m{ ^ \s* [+-]? \d++ \s* $ }x;
+}
+
+$_ = 'UNDERBAR';
+if (my $input = prompt " (this should be on the same line): ", -i, -out=>\*STDERR) {
+ $ok{'Assignment prompt'} = $input =~ m{ ^ \s* [+-]? \d++ \s* $ }x;
+ $ok{'$_ unaffected'} = $_ eq 'UNDERBAR';
+}
+
+for my $test (keys %ok) {
+ ok $ok{$test} => $test;
+}
+
+
+
diff --git a/t/interactive_wipe.t b/t/interactive_wipe.t
new file mode 100644
index 0000000..9545e6b
--- /dev/null
+++ b/t/interactive_wipe.t
@@ -0,0 +1,36 @@
+use 5.010;
+use warnings;
+use Test::More;
+
+use IO::Prompter;
+
+if (!-t *STDIN || !-t *STDERR) {
+ plan('skip_all' => 'Non-interactive test environment');
+}
+else {
+ plan('no_plan');
+}
+
+my %ok = (
+ 'Pure prompt' => 0,
+ 'Assignment prompt' => 0,
+ '$_ unaffected' => 0,
+);
+
+if (prompt -i, "\n\tShould have cleared screen. Enter an integer: ",
+ -wipe, -out=>\*STDERR) {
+ $ok{'Pure prompt'} = m{ ^ \s* [+-]? \d++ \s* $ }x;
+}
+
+$_ = 'UNDERBAR';
+if (my $input = prompt -i, -w_, -out=>\*STDERR,
+ "\tShould have cleared again. Enter another integer: ") {
+ $ok{'Assignment prompt'} = $input =~ m{ ^ \s* [+-]? \d++ \s* $ }x;
+ $ok{'$_ unaffected'} = $_ eq 'UNDERBAR';
+}
+
+for my $test (keys %ok) {
+ ok $ok{$test} => $test;
+}
+
+
diff --git a/t/interactive_wipe_wipefirst.t b/t/interactive_wipe_wipefirst.t
new file mode 100644
index 0000000..c939859
--- /dev/null
+++ b/t/interactive_wipe_wipefirst.t
@@ -0,0 +1,37 @@
+use 5.010;
+use warnings;
+use Test::More;
+
+use IO::Prompter;
+
+if (!-t *STDIN || !-t *STDERR) {
+ plan('skip_all' => 'Non-interactive test environment');
+}
+else {
+ plan('no_plan');
+}
+
+my %ok = (
+ 'Pure prompt' => 0,
+ 'Assignment prompt' => 0,
+ '$_ unaffected' => 0,
+);
+
+if (prompt -i, -wipe, -out=>\*STDERR,
+ "\n\tShould have cleared screen. Enter an integer: ") {
+ $ok{'Pure prompt'} = m{ ^ \s* [+-]? \d++ \s* $ }x;
+}
+
+$_ = 'UNDERBAR';
+if (my $input = prompt -i, -wipefirst, -out=>\*STDERR,
+ "\tShould NOT have cleared again. Enter another integer: "
+) {
+ $ok{'Assignment prompt'} = $input =~ m{ ^ \s* [+-]? \d++ \s* $ }x;
+ $ok{'$_ unaffected'} = $_ eq 'UNDERBAR';
+}
+
+for my $test (keys %ok) {
+ ok $ok{$test} => $test;
+}
+
+
diff --git a/t/interactive_wipefirst.t b/t/interactive_wipefirst.t
new file mode 100644
index 0000000..123ea44
--- /dev/null
+++ b/t/interactive_wipefirst.t
@@ -0,0 +1,37 @@
+use 5.010;
+use warnings;
+use Test::More;
+
+use IO::Prompter;
+
+if (!-t *STDIN || !-t *STDERR) {
+ plan('skip_all' => 'Non-interactive test environment');
+}
+else {
+ plan('no_plan');
+}
+
+my %ok = (
+ 'Pure prompt' => 0,
+ 'Assignment prompt' => 0,
+ '$_ unaffected' => 0,
+);
+
+if (prompt "\n\tShould have cleared screen. Enter an integer: ", -i,
+ -wipefirst, -out=>\*STDERR) {
+ $ok{'Pure prompt'} = m{ ^ \s* [+-]? \d++ \s* $ }x;
+}
+
+$_ = 'UNDERBAR';
+if (my $input = prompt -i, -wipefirst, -out=>\*STDERR,
+ "\tShould NOT have cleared again. Enter another integer: "
+) {
+ $ok{'Assignment prompt'} = $input =~ m{ ^ \s* [+-]? \d++ \s* $ }x;
+ $ok{'$_ unaffected'} = $_ eq 'UNDERBAR';
+}
+
+for my $test (keys %ok) {
+ ok $ok{$test} => $test;
+}
+
+
diff --git a/t/keyletters.t b/t/keyletters.t
new file mode 100644
index 0000000..a5cae20
--- /dev/null
+++ b/t/keyletters.t
@@ -0,0 +1,47 @@
+use 5.010;
+use warnings;
+use Test::More 'no_plan';
+
+use IO::Prompter;
+
+local *ARGV;
+open *ARGV, '<', \<<END_INPUT or die $!;
+N
+Y
+z
+
+EX
+END_INPUT
+
+if (prompt "(y)o or ba(z)", -keyletters) {
+ is $_, 'Y' => 'First keyletter retrieved';
+}
+else {
+ fail 'First keyletter retrieved';
+}
+
+
+if (prompt "e(y)e or (z)en", -keylets) {
+ is $_, 'z' => 'Second keyletter retrieved';
+}
+else {
+ fail 'Second keyletter retrieved';
+}
+
+
+
+if (prompt "(ex)it, [y]up or (z)en", -key) {
+ is $_, 'y' => 'Default keyletter retrieved';
+}
+else {
+ fail 'Default keyletter retrieved';
+}
+
+if (prompt "(ex)it, [y]up or (z)en", -_k) {
+ is $_, 'EX' => 'Multi-character keyletter retrieved';
+}
+else {
+ fail 'Multi-character keyletter retrieved';
+}
+
+
diff --git a/t/lexical_options.t b/t/lexical_options.t
new file mode 100644
index 0000000..e04b39f
--- /dev/null
+++ b/t/lexical_options.t
@@ -0,0 +1,64 @@
+use 5.010;
+use warnings;
+use Test::More 'no_plan';
+
+use IO::Prompter;
+
+local *ARGV;
+open *ARGV, '<', \<<END_INPUT or die $!;
+1
+a
+b
+-2234
+-1
+0
+2
+1
+3
+5
+-177
+END_INPUT
+
+{
+ use IO::Prompter [-integer];
+
+ if (prompt "Enter an integer: ") {
+ like $_, qr/^\s*[+-]?\d++\s*/ => 'First line retrieved';
+ }
+ else {
+ fail 'First line retrieved';
+ }
+
+ {
+ $_ = 'UNDERBAR';
+ if (my $input = prompt "Enter another integer: ") {
+ like $input, qr/^\s*[+-]?\d++\s*/ => 'Second line retrieved';
+ is $_, 'UNDERBAR' => 'Second line left $_ alone';
+ }
+ else {
+ fail 'Second line retrieved';
+ }
+ }
+}
+
+{
+ use IO::Prompter [-must=>{'be pos odd'=>sub{ $_ > 0 && $_ % 2}}];
+
+ if (prompt "Enter an integer: ") {
+ is $_, 1 => 'Constrained line retrieved';
+ }
+ else {
+ fail 'Constrained line retrieved';
+ }
+
+ use IO::Prompter []; # Turn off previous options
+
+ if (prompt -integer=>qr/7/, "Enter an integer: ") {
+ is $_, -177 => 'Constrained line 2 retrieved';
+ }
+ else {
+ fail 'Constrained line 2 retrieved';
+ }
+}
+
+
diff --git a/t/line.t b/t/line.t
new file mode 100644
index 0000000..abaebd3
--- /dev/null
+++ b/t/line.t
@@ -0,0 +1,28 @@
+use 5.010;
+use warnings;
+use Test::More 'no_plan';
+
+use IO::Prompter;
+
+local *ARGV;
+open *ARGV, '<', \<<END_INPUT or die $!;
+Line 1
+Line 2
+END_INPUT
+
+if (prompt "Enter line 1", -line) {
+ is $_, "Line 1\n" => 'First line retrieved';
+}
+else {
+ fail 'First line retrieved';
+}
+
+$_ = 'UNDERBAR';
+if (my $input = prompt "Enter line 2", -l_) {
+ is $input, "Line 2\n" => 'Second line retrieved';
+ is $_, 'UNDERBAR' => 'Second line left $_ alone'
+}
+else {
+ fail 'Second line retrieved';
+}
+
diff --git a/t/list_context.t b/t/list_context.t
new file mode 100644
index 0000000..7428a64
--- /dev/null
+++ b/t/list_context.t
@@ -0,0 +1,54 @@
+use 5.010;
+use warnings;
+use Test::More 'no_plan';
+
+use IO::Prompter;
+
+local *ARGV;
+open *ARGV, '<', \<<END_INPUT or die $!;
+Line 1
+Line 2
+END_INPUT
+
+if (my ($input) = prompt "Enter line 1") {
+ is $input, 'Line 1' => 'First line retrieved';
+}
+else {
+ fail 'First line retrieved';
+}
+
+$_ = 'UNDERBAR';
+if (my ($input) = prompt "Enter line 2") {
+ is $input, 'Line 2' => 'Second line retrieved';
+ is $_, 'UNDERBAR' => 'Second line left $_ alone'
+}
+else {
+ fail 'Second line retrieved';
+}
+
+if (my @input = prompt "Enter line 3") {
+ fail "empty list on failure (unexpectedly got qw<@input>)";
+}
+else {
+ ok !@input => 'empty list on failure';
+}
+
+{
+ open my $fh, '<', \q{} or die $!;
+ my @inputs = (
+ prompt('test', -in=>$fh),
+ prompt('test', -in=>$fh),
+ prompt('test', -in=>$fh),
+ );
+ ok @inputs == 0, 'Correct number of inputs on failure';
+}
+
+{
+ open my $fh, '<', \q{} or die $!;
+ my @inputs = (
+ scalar prompt('test', -in=>$fh),
+ scalar prompt('test', -in=>$fh),
+ scalar prompt('test', -in=>$fh),
+ );
+ ok @inputs == 3, 'Correct number of scalar inputs on failure';
+}
diff --git a/t/must.t b/t/must.t
new file mode 100644
index 0000000..d141ec8
--- /dev/null
+++ b/t/must.t
@@ -0,0 +1,57 @@
+use 5.010;
+use warnings;
+use Test::More 'no_plan';
+
+use IO::Prompter;
+
+local *ARGV;
+open *ARGV, '<', \<<END_INPUT or die $!;
+Line 1
+Line 2
+42
+7
+Another line
+Text
+42
+7
+cat
+END_INPUT
+
+if (prompt "Enter line 1", -must => { 'have a 2' => qr/2/ }) {
+ is $_, 'Line 2' => 'First line retrieved';
+}
+else {
+ fail 'First line retrieved';
+}
+
+if (prompt "Enter line 2", -must => { 'be in [1..10]' => [1..10] }) {
+ is $_, '7' => 'Second line retrieved';
+}
+else {
+ fail 'Second line retrieved';
+}
+
+
+if (prompt "Enter line 3", -must => { 'be Text' => ['Text'] }) {
+ is $_, 'Text' => 'Third line retrieved';
+}
+else {
+ fail 'Third line retrieved';
+}
+
+
+if (prompt "Enter line 4", -must => { 'Enter 7' => qr/^7$/ }) {
+ is $_, '7' => 'Fourth line retrieved';
+}
+else {
+ fail 'Fourth line retrieved';
+}
+
+
+if (prompt "Enter line 5", -must => { 'Woof!' => ['dog'] }) {
+ fail 'Last line should fail';
+}
+else {
+ pass 'Last line should fail';
+}
+
diff --git a/t/no_term_readkey.t b/t/no_term_readkey.t
new file mode 100644
index 0000000..8912af1
--- /dev/null
+++ b/t/no_term_readkey.t
@@ -0,0 +1,29 @@
+use lib qw< slib >;
+use 5.010;
+use warnings;
+use Test::More 'no_plan';
+
+use IO::Prompter;
+
+local *ARGV;
+open *ARGV, '<', \<<END_INPUT or die $!;
+Line 1
+Line 2
+END_INPUT
+
+if (prompt "Enter line 1") {
+ is $_, 'Line 1' => 'First line retrieved';
+}
+else {
+ fail 'First line retrieved';
+}
+
+$_ = 'UNDERBAR';
+if (my $input = prompt "Enter line 2") {
+ is $input, 'Line 2' => 'Second line retrieved';
+ is $_, 'UNDERBAR' => 'Second line left $_ alone'
+}
+else {
+ fail 'Second line retrieved';
+}
+
diff --git a/t/number.t b/t/number.t
new file mode 100644
index 0000000..b2c912a
--- /dev/null
+++ b/t/number.t
@@ -0,0 +1,30 @@
+use 5.010;
+use warnings;
+use Test::More 'no_plan';
+
+use IO::Prompter;
+
+local *ARGV;
+open *ARGV, '<', \<<END_INPUT or die $!;
+-1.234e+21
+a
+b
+-.2234
+END_INPUT
+
+if (prompt -number, "Enter an integer: ") {
+ ok $_ == -1.234e21 => 'First line retrieved';
+}
+else {
+ fail 'First line retrieved';
+}
+
+$_ = 'UNDERBAR';
+if (my $input = prompt -n, "Enter another integer: ") {
+ ok $input = -0.2234 => 'Second line retrieved';
+ is $_, 'UNDERBAR' => 'Second line left $_ alone'
+}
+else {
+ fail 'Second line retrieved';
+}
+
diff --git a/t/orlast.t b/t/orlast.t
new file mode 100644
index 0000000..ea8f621
--- /dev/null
+++ b/t/orlast.t
@@ -0,0 +1,20 @@
+use 5.010;
+use warnings;
+use Test::More tests=>2;
+
+use IO::Prompter;
+
+local *ARGV;
+open *ARGV, '<', \<<END_INPUT or die $!;
+Line 1
+Line 2
+Line 3
+END_INPUT
+
+while (1) {
+ my $l1 = prompt "Enter line 1" or last;
+ my $l2 = prompt "Enter line 2" or last;
+ is $l1, 'Line 1' => 'First line retrieved';
+ is $l2, 'Line 2' => 'Second line retrieved';
+}
+
diff --git a/t/pod-coverage.t b/t/pod-coverage.t
new file mode 100644
index 0000000..703f91d
--- /dev/null
+++ b/t/pod-coverage.t
@@ -0,0 +1,6 @@
+#!perl -T
+
+use Test::More;
+eval "use Test::Pod::Coverage 1.04";
+plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@;
+all_pod_coverage_ok();
diff --git a/t/pod.t b/t/pod.t
new file mode 100644
index 0000000..976d7cd
--- /dev/null
+++ b/t/pod.t
@@ -0,0 +1,6 @@
+#!perl -T
+
+use Test::More;
+eval "use Test::Pod 1.14";
+plan skip_all => "Test::Pod 1.14 required for testing POD" if $@;
+all_pod_files_ok();
diff --git a/t/simple.t b/t/simple.t
new file mode 100644
index 0000000..c832332
--- /dev/null
+++ b/t/simple.t
@@ -0,0 +1,28 @@
+use 5.010;
+use warnings;
+use Test::More 'no_plan';
+
+use IO::Prompter;
+
+local *ARGV;
+open *ARGV, '<', \<<END_INPUT or die $!;
+Line 1
+Line 2
+END_INPUT
+
+if (prompt "Enter line 1") {
+ is $_, 'Line 1' => 'First line retrieved';
+}
+else {
+ fail 'First line retrieved';
+}
+
+$_ = 'UNDERBAR';
+if (my $input = prompt "Enter line 2") {
+ is $input, 'Line 2' => 'Second line retrieved';
+ is $_, 'UNDERBAR' => 'Second line left $_ alone'
+}
+else {
+ fail 'Second line retrieved';
+}
+
diff --git a/t/single.t b/t/single.t
new file mode 100644
index 0000000..0be82b8
--- /dev/null
+++ b/t/single.t
@@ -0,0 +1,36 @@
+use 5.010;
+use warnings;
+use Test::More 'no_plan';
+
+use IO::Prompter;
+
+local *ARGV;
+open *ARGV, '<', \<<END_INPUT or die $!;
+a Line 1
+b Line 2
+c Line 3
+END_INPUT
+
+if (prompt -single, "Enter line 1") {
+ is $_, 'a' => 'First character retrieved';
+}
+else {
+ fail 'First line retrieved';
+}
+
+$_ = 'UNDERBAR';
+if (my $input = prompt -1, "Enter character 2") {
+ is $input, 'b' => 'Second character retrieved';
+ is $_, 'UNDERBAR' => 'Second line left $_ alone'
+}
+else {
+ fail 'Second line retrieved';
+}
+
+if (prompt -s_, "Enter line 1") {
+ is $_, 'c' => 'First character retrieved';
+}
+else {
+ fail 'First line retrieved';
+}
+
diff --git a/t/styles.t b/t/styles.t
new file mode 100644
index 0000000..8f3c0e5
--- /dev/null
+++ b/t/styles.t
@@ -0,0 +1,83 @@
+use 5.010;
+use warnings;
+use Test::More;
+
+use IO::Prompter;
+
+# Should we test at all???
+if (!-t *STDIN || !-t *STDERR) {
+ plan('skip_all' => 'Non-interactive test environment');
+ exit;
+}
+elsif ($^O =~ /Win/) {
+ plan('skip_all' => 'Skipping interactive tests under Windows');
+}
+elsif (!eval { require Term::ReadKey }) {
+ plan('skip_all' => 'Term::ReadKey not available');
+ exit;
+}
+else {
+ plan('no_plan');
+}
+select *STDERR;
+say {STDERR} q{};
+
+# Remember the test results...
+my %ok;
+
+# Load sample display styles to test...
+chomp(my @styles = <DATA>);
+
+# Test styled prompts...
+for my $style_spec (@styles) {
+ # Show the styled text and ask if it's correct...
+ my $result = prompt "\tIs this $style_spec?",
+ -yn1,
+ -style=>[$style_spec],
+ -echo=>sub{ /y/i ? 'yes, it is' : "no, it isn't" };
+
+ # Record the result...
+ push @results, {test=>$style_spec, outcome=>$result};
+}
+
+# Test styled responses...
+{
+ # Ask for an initial response...
+ my $last_style = $styles[0];
+ scalar prompt -echostyle=>$last_style, "\tType in something:";
+
+ # Check the colour of the previous response...
+ for my $style_spec (@styles[1..$#styles], q{}) {
+ my $result = prompt -yn1, -echostyle=>$style_spec,
+ -echo=>sub{ /y/i ? 'yes, it was' : "no, it wasn't"; },
+ "\tWas your previous input displayed in $last_style?";
+ push @results, {test=>$last_style, outcome=>$result};
+ $last_style = $style_spec;
+ }
+}
+
+# Test the "yes" half of yes/no shortcuts...
+scalar prompt -yn1, -echo=>'yes/no', -echostyle=>'cyan/red', "Is 1 an odd number?";
+my $result = prompt -yn1, 'Was the previous "yes" input echoed in cyan?';
+push @results, {test=>'Yes --> cyan', outcome=>$result};
+
+# Test the "no" half of the yes/no shortcuts...
+scalar prompt -yn1, -echo=>'yes/no', -echostyle=>'cyan/red', "Is 2 an odd number?";
+$result = prompt -yn1, 'Was the previous "no" input echoed in red?';
+push @results, {test=>'No --> red', outcome=>$result};
+
+# Report the results...
+for my $result (@results) {
+ ok $result->{outcome} => $result->{test};
+}
+
+__DATA__
+red
+murky green
+blue
+black on cyan
+bold green
+inverse
+underscored yellow
+blinking purple
+strong crimson on a background of gold
diff --git a/t/timeout.t b/t/timeout.t
new file mode 100644
index 0000000..d61f073
--- /dev/null
+++ b/t/timeout.t
@@ -0,0 +1,74 @@
+use 5.010;
+use warnings;
+use Test::More;
+
+use IO::Prompter;
+
+if (!-t *STDIN || !-t *STDERR) {
+ plan('skip_all' => 'Non-interactive test environment');
+}
+else {
+ plan('no_plan');
+}
+
+my $output;
+open my $out_fh, '>', \$output;
+
+my $start_time;
+
+# Long form, non-zero delay fail...
+if (prompt q{}, -timeout=>1.5, -out=>$out_fh) {
+ fail 'Time-out of -timeout=>1.5';
+}
+else {
+ pass 'Time-out of -timeout=>1.5';
+}
+
+# Long form, instantaneous fail...
+if (prompt q{}, -timeout=>0, -out=>$out_fh) {
+ fail 'Time-out of -timeout=>0';
+}
+else {
+ pass 'Time-out of -timeout=>0';
+}
+
+# Short form, non-zero delay fail...
+if (prompt q{}, -t1, -out=>$out_fh) {
+ fail 'Time-out of -t1';
+}
+else {
+ pass 'Time-out of -t1';
+}
+
+# Short form, instantaneous fail...
+if (prompt q{}, -t0, -out=>$out_fh) {
+ fail 'Time-out of -t0';
+}
+else {
+ pass 'Time-out of -t0';
+}
+
+# Short form, instantaneous success...
+if (prompt q{}, -t0, -in=>*DATA, -out=>$out_fh) {
+ pass 'Non-time-out of -t0';
+ is $_, 'Data line 1' => 'Correct input';
+}
+else {
+ fail 'Non-time-out of -t0';
+}
+
+# Short form, instantaneous success, non-file...
+my $pseudofile = "Pseudofile line 1\n";
+open my $fh, '<', \$pseudofile
+ or die $!;
+if (prompt q{}, -t0, -in=>$fh, -out=>$out_fh) {
+ pass 'Non-time-out of -t0';
+ is $_, 'Pseudofile line 1' => 'Correct input';
+}
+else {
+ fail 'Non-time-out of -t0';
+}
+
+__DATA__
+Data line 1
+Data line 2
diff --git a/t/timeout_no_term_readkey.t b/t/timeout_no_term_readkey.t
new file mode 100644
index 0000000..b0836a7
--- /dev/null
+++ b/t/timeout_no_term_readkey.t
@@ -0,0 +1,77 @@
+
+use lib qw< slib >;
+
+use 5.010;
+use warnings;
+use Test::More;
+
+use IO::Prompter;
+
+if (!-t *STDIN || !-t *STDERR) {
+ plan('skip_all' => 'Non-interactive test environment');
+}
+else {
+ plan('no_plan');
+}
+
+my $output;
+open my $out_fh, '>', \$output;
+
+my $start_time;
+
+# Long form, non-zero delay fail...
+if (prompt q{}, -timeout=>1.5, -out=>$out_fh) {
+ fail 'Time-out of -timeout=>1.5';
+}
+else {
+ pass 'Time-out of -timeout=>1.5';
+}
+
+# Long form, instantaneous fail...
+if (prompt q{}, -timeout=>0, -out=>$out_fh) {
+ fail 'Time-out of -timeout=>0';
+}
+else {
+ pass 'Time-out of -timeout=>0';
+}
+
+# Short form, non-zero delay fail...
+if (prompt q{}, -t1, -out=>$out_fh) {
+ fail 'Time-out of -t1';
+}
+else {
+ pass 'Time-out of -t1';
+}
+
+# Short form, instantaneous fail...
+if (prompt q{}, -t0, -out=>$out_fh) {
+ fail 'Time-out of -t0';
+}
+else {
+ pass 'Time-out of -t0';
+}
+
+# Short form, instantaneous success...
+if (prompt q{}, -t0, -in=>*DATA, -out=>$out_fh) {
+ pass 'Non-time-out of -t0';
+ is $_, 'Data line 1' => 'Correct input';
+}
+else {
+ fail 'Non-time-out of -t0';
+}
+
+# Short form, instantaneous success, non-file...
+my $pseudofile = "Pseudofile line 1\n";
+open my $fh, '<', \$pseudofile
+ or die $!;
+if (prompt q{}, -t0, -in=>$fh, -out=>$out_fh) {
+ pass 'Non-time-out of -t0';
+ is $_, 'Pseudofile line 1' => 'Correct input';
+}
+else {
+ fail 'Non-time-out of -t0';
+}
+
+__DATA__
+Data line 1
+Data line 2
diff --git a/t/verbatim.t b/t/verbatim.t
new file mode 100644
index 0000000..4c52c4a
--- /dev/null
+++ b/t/verbatim.t
@@ -0,0 +1,34 @@
+use 5.010;
+use warnings;
+use Test::More 'no_plan';
+
+use IO::Prompter;
+
+local *ARGV;
+open *ARGV, '<', \<<END_INPUT or die $!;
+Line 1
+Line 2
+END_INPUT
+
+if (my $input = prompt -verbatim, "Enter line 1") {
+ is $input, 'Line 1' => 'First line retrieved';
+}
+else {
+ fail 'First line retrieved';
+}
+
+$_ = 'UNDERBAR';
+if (my $input = prompt -v, "Enter line 2") {
+ is $input, 'Line 2' => 'Second line retrieved';
+ is $_, 'UNDERBAR' => 'Second line left $_ alone'
+}
+else {
+ fail 'Second line retrieved';
+}
+
+if (my $input = prompt -v, "Enter line 3") {
+ fail 'undef on failure (unexpectedly got "$input")';
+}
+else {
+ ok !defined $input => 'undef on failure';
+}
diff --git a/t/yesno.t b/t/yesno.t
new file mode 100644
index 0000000..7f1dc33
--- /dev/null
+++ b/t/yesno.t
@@ -0,0 +1,94 @@
+use 5.010;
+use warnings;
+use Test::More 'no_plan';
+
+use IO::Prompter;
+
+# -yesno
+
+local *ARGV;
+open *ARGV, '<', \<<END_INPUT or die $!;
+y
+y
+n
+a
+yes
+y
+END_INPUT
+
+ok prompt("Enter line 1", -yesno) => "-yesno 1";
+ok prompt("Enter line 1", -yn) => "-yn 2";
+ok !prompt("Enter line 1", -yesno) => "-yesno 3";
+ok prompt("Enter line 1", -yesno) => "-yesno 4";
+ok prompt("Enter line 1", -yesno) => "-yesno 4";
+ok eof(*ARGV) => "-yesno complete";
+
+
+# -YesNo
+
+local *ARGV;
+open *ARGV, '<', \<<END_INPUT or die $!;
+Y
+y
+Y
+n
+N
+a
+Yes
+Y
+END_INPUT
+
+ok prompt("Enter line 1", -YesNo) => "-YesNo 1";
+ok prompt("Enter line 1", -YN) => "-YN 2";
+ok !prompt("Enter line 1", -YesNo) => "-YesNo 3";
+ok prompt("Enter line 1", -YesNo) => "-YesNo 4";
+ok prompt("Enter line 1", -YesNo) => "-YesNo 4";
+ok eof(*ARGV) => "-YesNo complete";
+
+
+# -yes
+
+local *ARGV;
+open *ARGV, '<', \<<END_INPUT or die $!;
+y
+y
+n
+a
+yes
+y
+END_INPUT
+
+ok prompt("Enter line 1", -yes) => "-yes 1";
+ok prompt("Enter line 1", -y_) => "-y 2";
+ok !prompt("Enter line 1", -yes) => "-yes 3";
+ok !prompt("Enter line 1", -yes) => "-yes 4";
+ok prompt("Enter line 1", -yes) => "-yes 5";
+ok prompt("Enter line 1", -yes) => "-yes 6";
+ok eof(*ARGV) => "-yes complete";
+
+
+# -Yes
+
+local *ARGV;
+open *ARGV, '<', \<<END_INPUT or die $!;
+Y
+y
+Y
+n
+N
+a
+Yes
+Y
+Y
+END_INPUT
+
+ok prompt("Enter line 1", -Yes) => "-Yes 1";
+ok prompt("Enter line 1", -Y) => "-Y 2";
+ok !prompt("Enter line 1", -Yes) => "-Yes 3";
+ok !prompt("Enter line 1", -Yes) => "-Yes 4";
+ok !prompt("Enter line 1", -Yes) => "-Yes 5";
+ok prompt("Enter line 1", -Yes) => "-Yes 6";
+ok prompt("Enter line 1", -Yes) => "-Yes 6";
+ok prompt("Enter line 1", -Yes) => "-Yes 7";
+ok eof(*ARGV) => "-Yes complete";
+
diff --git a/t/zen.t b/t/zen.t
new file mode 100644
index 0000000..9c4fc1f
--- /dev/null
+++ b/t/zen.t
@@ -0,0 +1,29 @@
+use 5.010;
+use warnings;
+use Test::More 'no_plan';
+
+use IO::Prompter;
+
+local *ARGV;
+open *ARGV, '<', \<<END_INPUT or die $!;
+Line 1
+Line 2
+END_INPUT
+
+if (prompt "Enter line 1", -l_) {
+ is $_, "Line 1\n" => 'First line retrieved';
+}
+else {
+ fail 'First line retrieved';
+}
+
+$_ = 'UNDERBAR';
+if (my $input = prompt "Enter line 2", -l_) {
+ is $input, "Line 2\n" => 'Second line retrieved';
+ is $_, 'UNDERBAR' => 'Second line left $_ alone'
+}
+else {
+ fail 'Second line retrieved';
+}
+
+
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-11 05:55:44 +0000