IO-Prompter-0.004010/000755 000765 000765 00000000000 12223224063 014605 5ustar00damiandamian000000 000000 IO-Prompter-0.004010/Changes000644 000765 000765 00000006370 12223224054 016106 0ustar00damiandamian000000 000000 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 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) IO-Prompter-0.004010/lib/000755 000765 000765 00000000000 12223224063 015353 5ustar00damiandamian000000 000000 IO-Prompter-0.004010/Makefile.PL000644 000765 000765 00000001065 11741622343 016570 0ustar00damiandamian000000 000000 use strict; use warnings; use ExtUtils::MakeMaker; WriteMakefile( NAME => 'IO::Prompter', AUTHOR => 'Damian Conway ', 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-*' }, ); IO-Prompter-0.004010/MANIFEST000644 000765 000765 00000001302 12223224063 015732 0ustar00damiandamian000000 000000 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 META.yml Module meta-data (added by MakeMaker) IO-Prompter-0.004010/META.yml000644 000765 000765 00000001134 12223224063 016055 0ustar00damiandamian000000 000000 --- #YAML:1.0 name: IO-Prompter version: 0.004010 abstract: Prompt for input, read it, clean it, return it. author: - Damian Conway license: perl distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: Contextual::Return: 0 Test::More: 0 no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.57_05 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 IO-Prompter-0.004010/README000644 000765 000765 00000002022 12223224054 015461 0ustar00damiandamian000000 000000 IO::Prompter version 0.004010 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. IO-Prompter-0.004010/t/000755 000765 000765 00000000000 12223224063 015050 5ustar00damiandamian000000 000000 IO-Prompter-0.004010/t/00.load.t000644 000765 000765 00000000226 11715022703 016374 0ustar00damiandamian000000 000000 use 5.010; use warnings; use Test::More tests => 1; BEGIN { use_ok( 'IO::Prompter' ); } diag( "Testing IO::Prompter $IO::Prompter::VERSION" ); IO-Prompter-0.004010/t/argv.t000644 000765 000765 00000000653 11715022704 016203 0ustar00damiandamian000000 000000 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'; } IO-Prompter-0.004010/t/bundled.t000644 000765 000765 00000000427 11745243632 016670 0ustar00damiandamian000000 000000 use 5.010; use warnings; use Test::More 'no_plan'; use IO::Prompter; local *ARGV; open *ARGV, '<', \< '-l effective'; ok !ref($result) => '-v effective'; IO-Prompter-0.004010/t/default.t000644 000765 000765 00000001256 11745243606 016701 0ustar00damiandamian000000 000000 use 5.010; use warnings; use Test::More 'no_plan'; use IO::Prompter; local *ARGV; open *ARGV, '<', \<'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'; } IO-Prompter-0.004010/t/errors.t000644 000765 000765 00000003301 11740355066 016561 0ustar00damiandamian000000 000000 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 { 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'; } IO-Prompter-0.004010/t/fail.t000644 000765 000765 00000001211 11715022710 016143 0ustar00damiandamian000000 000000 use 5.010; use warnings; use Test::More 'no_plan'; use IO::Prompter; local *ARGV; open *ARGV, '<', \<'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'; } IO-Prompter-0.004010/t/fake.t000644 000765 000765 00000001070 11715022711 016142 0ustar00damiandamian000000 000000 use 5.010; use warnings; use Test::More 'no_plan'; use IO::Prompter; local *ARGV; open *ARGV, '<', \<\*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 <; use 5.010; use warnings; use Test::More 'no_plan'; use IO::Prompter; local *ARGV; open *ARGV, '<', \<\*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 <', \$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'; } IO-Prompter-0.004010/t/guarantee.t000644 000765 000765 00000001544 11372460751 017226 0ustar00damiandamian000000 000000 use 5.010; use warnings; use Test::More 'no_plan'; use IO::Prompter; local *ARGV; open *ARGV, '<', \<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'; } IO-Prompter-0.004010/t/integer.t000644 000765 000765 00000001563 11741106646 016711 0ustar00damiandamian000000 000000 use 5.010; use warnings; use Test::More 'no_plan'; use IO::Prompter; local *ARGV; open *ARGV, '<', \< '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'; } IO-Prompter-0.004010/t/interactive.t000644 000765 000765 00000001274 12222177610 017562 0ustar00damiandamian000000 000000 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; } IO-Prompter-0.004010/t/interactive_echo.t000644 000765 000765 00000002111 12222177610 020547 0ustar00damiandamian000000 000000 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; } IO-Prompter-0.004010/t/interactive_no_term_readkey.t000644 000765 000765 00000001274 12222177610 023011 0ustar00damiandamian000000 000000 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; } IO-Prompter-0.004010/t/interactive_out.t000644 000765 000765 00000001245 12222177610 020447 0ustar00damiandamian000000 000000 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; } IO-Prompter-0.004010/t/interactive_return.t000644 000765 000765 00000001315 12222177610 021155 0ustar00damiandamian000000 000000 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; } IO-Prompter-0.004010/t/interactive_wipe.t000644 000765 000765 00000001412 12222177610 020600 0ustar00damiandamian000000 000000 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; } IO-Prompter-0.004010/t/interactive_wipe_wipefirst.t000644 000765 000765 00000001423 12222177610 022676 0ustar00damiandamian000000 000000 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; } IO-Prompter-0.004010/t/interactive_wipefirst.t000644 000765 000765 00000001433 12222177610 021653 0ustar00damiandamian000000 000000 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; } IO-Prompter-0.004010/t/keyletters.t000644 000765 000765 00000001352 11717315511 017437 0ustar00damiandamian000000 000000 use 5.010; use warnings; use Test::More 'no_plan'; use IO::Prompter; local *ARGV; open *ARGV, '<', \< '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'; } IO-Prompter-0.004010/t/lexical_options.t000644 000765 000765 00000002217 11741107511 020435 0ustar00damiandamian000000 000000 use 5.010; use warnings; use Test::More 'no_plan'; use IO::Prompter; local *ARGV; open *ARGV, '<', \< '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'; } } IO-Prompter-0.004010/t/line.t000644 000765 000765 00000000770 11672564511 016204 0ustar00damiandamian000000 000000 use 5.010; use warnings; use Test::More 'no_plan'; use IO::Prompter; local *ARGV; open *ARGV, '<', \< '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'; } IO-Prompter-0.004010/t/list_context.t000644 000765 000765 00000002210 11750302676 017762 0ustar00damiandamian000000 000000 use 5.010; use warnings; use Test::More 'no_plan'; use IO::Prompter; local *ARGV; open *ARGV, '<', \< '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'; } IO-Prompter-0.004010/t/must.t000644 000765 000765 00000001676 11715022731 016242 0ustar00damiandamian000000 000000 use 5.010; use warnings; use Test::More 'no_plan'; use IO::Prompter; local *ARGV; open *ARGV, '<', \< { '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'; } IO-Prompter-0.004010/t/no_term_readkey.t000644 000765 000765 00000000775 11727541114 020424 0ustar00damiandamian000000 000000 use lib qw< slib >; use 5.010; use warnings; use Test::More 'no_plan'; use IO::Prompter; local *ARGV; open *ARGV, '<', \< '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'; } IO-Prompter-0.004010/t/number.t000644 000765 000765 00000001035 11715022733 016531 0ustar00damiandamian000000 000000 use 5.010; use warnings; use Test::More 'no_plan'; use IO::Prompter; local *ARGV; open *ARGV, '<', \< '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'; } IO-Prompter-0.004010/t/orlast.t000644 000765 000765 00000000546 11715022734 016554 0ustar00damiandamian000000 000000 use 5.010; use warnings; use Test::More tests=>2; use IO::Prompter; local *ARGV; open *ARGV, '<', \< 'First line retrieved'; is $l2, 'Line 2' => 'Second line retrieved'; } IO-Prompter-0.004010/t/pod-coverage.t000644 000765 000765 00000000254 11176522771 017626 0ustar00damiandamian000000 000000 #!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(); IO-Prompter-0.004010/t/pod.t000644 000765 000765 00000000214 11176522771 016031 0ustar00damiandamian000000 000000 #!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(); IO-Prompter-0.004010/t/simple.t000644 000765 000765 00000000751 11715022737 016542 0ustar00damiandamian000000 000000 use 5.010; use warnings; use Test::More 'no_plan'; use IO::Prompter; local *ARGV; open *ARGV, '<', \< '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'; } IO-Prompter-0.004010/t/single.t000644 000765 000765 00000001215 11715022740 016520 0ustar00damiandamian000000 000000 use 5.010; use warnings; use Test::More 'no_plan'; use IO::Prompter; local *ARGV; open *ARGV, '<', \< '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'; } IO-Prompter-0.004010/t/styles.t000644 000765 000765 00000004431 12115604746 016574 0ustar00damiandamian000000 000000 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 = ); # 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 IO-Prompter-0.004010/t/timeout.t000644 000765 000765 00000002634 12222177610 016734 0ustar00damiandamian000000 000000 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 IO-Prompter-0.004010/t/timeout_no_term_readkey.t000644 000765 000765 00000002662 12222177610 022164 0ustar00damiandamian000000 000000 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 IO-Prompter-0.004010/t/verbatim.t000644 000765 000765 00000001251 11750301337 017051 0ustar00damiandamian000000 000000 use 5.010; use warnings; use Test::More 'no_plan'; use IO::Prompter; local *ARGV; open *ARGV, '<', \< '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'; } IO-Prompter-0.004010/t/yesno.t000644 000765 000765 00000003414 11745256660 016414 0ustar00damiandamian000000 000000 use 5.010; use warnings; use Test::More 'no_plan'; use IO::Prompter; # -yesno local *ARGV; open *ARGV, '<', \< "-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, '<', \< "-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, '<', \< "-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, '<', \< "-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"; IO-Prompter-0.004010/t/zen.t000644 000765 000765 00000000767 11715022747 016055 0ustar00damiandamian000000 000000 use 5.010; use warnings; use Test::More 'no_plan'; use IO::Prompter; local *ARGV; open *ARGV, '<', \< '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'; } IO-Prompter-0.004010/lib/IO/000755 000765 000765 00000000000 12223224063 015662 5ustar00damiandamian000000 000000 IO-Prompter-0.004010/lib/IO/Prompter.pm000644 000765 000765 00000350535 12223224054 020043 0ustar00damiandamian000000 000000 use 5.010; package IO::Prompter; use warnings; no if $] >= 5.018000, warnings => 'experimental'; use strict; use Carp; use Contextual::Return; use Scalar::Util qw< openhandle looks_like_number >; use Symbol qw< qualify_to_ref >; our $VERSION = '0.004010'; 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{ [$COMPLETE_KEY$COMPLETE_HIST] }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 $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... my @lexical_options = []; # 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; } # 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 { _warn( void => 'Useless use of prompt() in void context' ) if VOID; # 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]}, @_); # Set up yesno prompts if required... my @yesno_prompts = ($opt_ref->{-yesno}{count}//0) > 1 ? @YESNO_PROMPTS : (); # Work out where the prompts go, and where the input comes from... my $in_filehandle = $opt_ref->{-in} // _open_ARGV(); my $out_filehandle = $opt_ref->{-out} // qualify_to_ref(select); if (!openhandle $in_filehandle) { open my $fh, '<', $in_filehandle or _opt_err('Unacceptable', '-in', 'valid filehandle or filename'); $in_filehandle = $fh; } if (!openhandle $out_filehandle) { open my $fh, '>', $out_filehandle or _opt_err('Unacceptable', '-out', 'valid filehandle or filename'); $out_filehandle = $fh; } # Track timeouts... my $in_pos = do { no warnings; tell $in_filehandle } // 0; # Short-circuit if not valid handles... return if !openhandle($in_filehandle) || !openhandle($out_filehandle); # Work out how they're arriving and departing... my $outputter_ref = -t $in_filehandle && -t $out_filehandle ? _std_printer_to($out_filehandle, $opt_ref) : _null_printer() ; my $inputter_ref = _generate_unbuffered_reader_from( $in_filehandle, $outputter_ref, $opt_ref ); # Clear the screen if requested to... if ($opt_ref->{-wipe}) { $outputter_ref->(-nostyle => "\n" x 1000); } # Handle menu structures... my $input; REPROMPT_YESNO: if ($opt_ref->{-menu}) { # Remember top of (possibly nested) menu... my @menu = ( $opt_ref->{-menu} ); my $top_prompt = $opt_ref->{-prompt}; $top_prompt =~ s{$MENU_MK}{$opt_ref->{-menu}{prompt}}xms; $menu[-1]{prompt} = $top_prompt; MENU: while (1) { # Track the current level... $opt_ref->{-menu_curr_level} = $menu[-1]{value_for}; # Show menu and retreive choice... $outputter_ref->(-style => $menu[-1]{prompt}); my $tag = $inputter_ref->($menu[-1]{constraint}); # Handle a failure by exiting the loop... last MENU if !defined $tag; $tag =~ s{\A\s*(\S*).*}{$1}xms; # Handle by moving up menu stack... if ($tag eq $MENU_ESC) { $input = undef; last MENU if @menu <= 1; pop @menu; next MENU; } # Handle defaults by selecting and ejecting... if ($tag =~ /\A\R?\Z/ && exists $opt_ref->{-def}) { $input = $tag; last MENU; } # Otherwise, retrieve value for selected tag and exit if not a nested menu... $input = $menu[-1]{value_for}{$tag}; last MENU if !ref $input; # Otherwise, go down the menu one level... push @menu, _build_menu($input, "Select from $menu[-1]{key_for}{$tag}: ", $opt_ref->{-number} || $opt_ref->{-integer} ); $menu[-1]{prompt} .= '> '; } } # Otherwise, simply ask and ye shall receive... else { $outputter_ref->(-style => $opt_ref->{-prompt}); $input = $inputter_ref->(); } # Provide default value if available and necessary... my $defaulted = 0; if (defined $input && $input =~ /\A\R?\Z/ && exists $opt_ref->{-def}) { $input = $opt_ref->{-def}; $defaulted = 1; } # The input line is usually chomped before being returned... if (defined $input && !$opt_ref->{-line}) { chomp $input; } # Check for a value indicating failure... if (exists $opt_ref->{-fail} && $input ~~ $opt_ref->{-fail}) { $input = undef; } # Setting @ARGV is a special case; process it like a command-line... if ($opt_ref->{-argv}) { @ARGV = map { _shell_expand($_) } grep {defined} $input =~ m{ ( ' [^'\\]* (?: \\. [^'\\]* )* ' ) | ( " [^"\\]* (?: \\. [^"\\]* )* " ) | (?: ^ | \s) ( [^\s"'] \S* ) }gxms; return 1; } # "Those who remember history are enabled to repeat it"... if (defined $input and $opt_ref->{-history} ne 'NONE') { my $history_set = $history_cache{ $opt_ref->{-history} } //= [] ; @{ $history_set } = ($input, grep { $_ ne $input } @{ $history_set }); } # If input timed out insert the default, if any... my $timedout = $in_pos == do{ no warnings; tell $in_filehandle } // 0; if ($timedout && exists $opt_ref->{-def}) { $input = $opt_ref->{-def}; $defaulted = 1; } # A defined input is a successful input... my $succeeded = defined $input; # The -yesno variants also need a 'y' to be successful... if ($opt_ref->{-yesno}{count}) { $succeeded &&= $input =~ m{\A \s* y}ixms; if ($succeeded && $opt_ref->{-yesno}{count} > 1) { my $count = --$opt_ref->{-yesno}{count}; $opt_ref->{-prompt} = @yesno_prompts ? shift(@yesno_prompts) . q{ } : $count > 1 ? qq{Please confirm $count more times } : q{Please confirm one last time } ; goto REPROMPT_YESNO; # Gasp, yes goto is the cleanest way! } } # Verbatim return doesn't do fancy tricks... if ($opt_ref->{-verbatim}) { return $input // (); } # Failure in a list context returns nothing... return if LIST && !$succeeded; # Otherwise, be context sensitive... return PUREBOOL { $_ = RETOBJ; next handler; } BOOL { $succeeded; } SCALAR { $input; } METHOD { defaulted => sub { $defaulted }, timedout => sub { return q{} if !$timedout; return "timed out after $opt_ref->{-timeout} second" . ($opt_ref->{-timeout} == 1 ? q{} : q{s}); }, }; } # Simulate a command line expansion for the -argv option... sub _shell_expand { my ($text) = @_; # Single-quoted text is literal... if ($text =~ m{\A ' (.*) ' \z}xms) { return $1; } # Everything else has shell variables expanded... my $ENV_PAT = join '|', reverse sort keys %ENV; $text =~ s{\$ ($ENV_PAT)}{$ENV{$1}}gxms; # Double-quoted text isn't globbed... if ($text =~ m{\A " (.*) " \z}xms) { return $1; } # Everything else is... return glob($text); } # No completion is the default... my $DEFAULT_COMPLETER = sub { q{} }; # Translate std constraints... my %STD_CONSTRAINT = ( positive => sub { $_ > 0 }, negative => sub { $_ < 0 }, zero => sub { $_ == 0 }, even => sub { $_ % 2 == 0 }, odd => sub { $_ % 2 != 0 }, ); # Create abbreviations... $STD_CONSTRAINT{pos} = $STD_CONSTRAINT{positive}; $STD_CONSTRAINT{neg} = $STD_CONSTRAINT{negative}; # Create antitheses... for my $constraint (keys %STD_CONSTRAINT) { my $implementation = $STD_CONSTRAINT{$constraint}; $STD_CONSTRAINT{"non$constraint"} = sub { ! $implementation->(@_) }; } # Special style specifications require decoding... sub _decode_echo { my $style = shift; # Not a special style... return $style if ref $style || $style !~ m{/}; # A slash means yes/no echoes... my ($yes, $no) = split m{/}, $style; return sub{ /y/i ? $yes : $no }; } sub _decode_echostyle { my $style = shift; # Not a special style... return $style if ref $style || $style !~ m{/}; # A slash means yes/no styles... my ($yes, $no) = split m{/}, $style; return sub{ /y/i ? $yes : $no }; } sub _decode_style { # No special prompt styles (yet)... return shift; } # Generate safe closure around active sub... sub _gen_wrapper_for { my ($arg) = @_; return ref $arg ne 'CODE' ? sub { $arg } : sub { eval { for (shift) { no warnings; return $arg->($_) // $_ } } }; } # Create recognizer... my $STD_CONSTRAINT = '^(?:' . join('|', reverse sort keys %STD_CONSTRAINT) . ')'; # Translate name constraints to implementations... sub _standardize_constraint { my ($option_type, $constraint_spec) = @_; return ("be an acceptable $option_type", $constraint_spec) if ref $constraint_spec; my @constraint_names = split /\s+/, $constraint_spec; my @constraints = map { $STD_CONSTRAINT{$_} // _opt_err('invalid',-$option_type,'"pos", "neg", "even", etc.') } @constraint_names; return ( 'be ' . join(' and ', @constraint_names), sub { my ($compare_val) = @_; for my $constraint (@constraints) { return 0 if !$constraint->($compare_val); } return 1; } ); } # Convert args to prompt + options hash... sub _decode_args { my %option = ( -prompt => undef, -complete => $DEFAULT_COMPLETER, -must => {}, -history => 'DEFAULT', -style => sub{ q{} }, -nostyle => sub{ q{} }, -echostyle => sub{ q{} }, -echo => sub { shift }, -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 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 { 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; if (defined $fake_input && length($fake_input) > 0) { $fake_input =~ s{ \A (.*) \R? }{}xm; $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 (split q{}, $local_fake_input) { _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} //= "\177"; 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; if (defined $fake_input && length($fake_input) > 0) { $fake_input =~ s{ \A (.*) \R? }{}xm; $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 && $next ne $completion_type) { $completion_type = $next; $completion_level = 1; } else { $completion_level++; } # If starting completion, cache completions... if ($completion_level == 1) { ($completion_prefix, @completion_list) = $next eq $COMPLETE_KEY ? _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}($_) } split //, $input_pre; my $display_post = join q{}, map { $opt_ref->{-echo}($_) } split //, $input_post; $outputter_ref->( -echostyle => "\b" x length($display_pre) . join(q{}, map { $opt_ref->{-echo}($_) } split //, $input) . 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) { 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 (split q{}, $local_fake_input) { _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}($_) } split //, $input_pre; my $display_post = join q{}, map { $opt_ref->{-echo}($_) } split //, $input_post; $outputter_ref->( -echostyle => "\b" x length($display_pre) . join(q{}, map { $opt_ref->{-echo}($_) } split //, $input) . "\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; say grep { $ctrl{$_} eq $next } keys %ctrl; next INPUT; } } if ($opt_ref->{-single} || !defined $next || $input =~ m{\Q$/\E$}) { # Did we get an acceptable value? if (defined $next) { _verify_input_constraints( \$input, \$local_fake_input, $outputter_ref, $opt_ref, $extra_constraints, ); } # Reset terminal... Term::ReadKey::ReadMode('restore', $in_fh); # Return failure if failed before input... return undef if !defined $next && length($input) == 0; # Otherwise supply a final newline if necessary... if ( $opt_ref->{-single} && exists $opt_ref->{-return} && $input !~ /\A\R\z/ ) { $outputter_ref->(-echostyle => $opt_ref->{-return}(q{})); } return $input; } } } } # Build a menu... sub _build_menu { my ($source_ref, $initial_prompt, $is_numeric) = @_; my $prompt = ($initial_prompt//q{}) . qq{\n}; my $final = q{}; my %value_for; my %key_for; my @selectors; given (ref $source_ref) { when ('HASH') { my @sorted_keys = sort(keys(%{$source_ref})); @selectors = $is_numeric ? (1..@sorted_keys) : ('a'..'z','A'..'Z'); @key_for{@selectors} = @sorted_keys; @value_for{@selectors} = @{$source_ref}{@sorted_keys}; $source_ref = \@sorted_keys; $_ = 'ARRAY'; continue; } when ('SCALAR') { $source_ref = [ split "\n", ${$source_ref} ]; $_ = 'ARRAY'; continue; } when ('ARRAY') { my @source = @{$source_ref}; @selectors = $is_numeric ? (1..@source) : ('a'..'z','A'..'Z'); if (!keys %value_for) { @value_for{@selectors} = @source; } ITEM: for my $tag (@selectors) { my $item = shift(@source) // last ITEM; chomp $item; $prompt .= sprintf("%4s. $item\n", $tag); $final = $tag; } if (@source) { _warn( misc => "prompt(): Too many menu items. Ignoring the final " . @source ); } } } my $constraint = $is_numeric ? '(?:' . join('|',@selectors) .')' : $final =~ /[A-Z]/ ? "[a-zA-$final]" : "[a-$final]"; my $constraint_desc = $is_numeric ? "[1-$selectors[-1]]" : $constraint; $constraint = '\A\s*' . $constraint . '\s*\Z'; return { data => $source_ref, key_for => \%key_for, value_for => \%value_for, prompt => "$prompt\n", is_numeric => $is_numeric, constraint => { "Enter $constraint_desc: " => qr/$constraint|$MENU_ESC/ }, }; } # Vocabulary that _stylize understands... my %synonyms = ( bold => [qw], dark => [qw], faint => [qw], underline => [qw], blink => [qw], reverse => [qw], concealed => [qw], 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.004010 =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 DESCRIPTION IO::Prompter exports a single subroutine, C, 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 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 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 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 to always return a value (i.e. even on failure), prefix the call with C: # Only produces as many elements # as there were successful inputs... my @data = ( prompt('Name:'), prompt(' Age:'), prompt(' Sex:'), ); # Always produces exactly three elements # (some of which may be failure objects)... my @data = ( scalar prompt('Name:'), scalar prompt(' Age:'), scalar prompt(' Sex:'), ); In void contexts, C 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"> for an exception to this. The C 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 or C<< <> >>. =head1 INTERFACE All the options for C 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, 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 , as specified -dSTR -def[ault]=>STR What to return if only 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 * -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) * -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 in the current lexical scope, by passing them (via an array reference) as the arguments to a C 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 to the argument list of any call to C in that scope. To turn off any existing automatic options for the rest of the current scope, use: use IO::Prompter []; =head2 Options reference =head3 Specifying what to prompt =over 4 C<< -prompt => I >> C<< -pI >> =back By default, any argument passed to C 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 adds a single space after it, to better format the output. On the other hand, if the prompt ends in a newline, C 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 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 >> =back If the C 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 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 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 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