IO-Prompter-0.005002/000755 000765 000024 00000000000 14751352043 014455 5ustar00damianstaff000000 000000 IO-Prompter-0.005002/Changes000644 000765 000024 00000011760 14751352033 015754 0ustar00damianstaff000000 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) 0.004011 Fri Jul 25 17:03:42 2014 * Added 'normal', 'default', 'standard', etc. to colour translation * Added at start of faked input to defer next fake and insert real input (i.e. like , 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!) 0.005000 Tue Jul 4 17:17:35 2023 * Added -monitor option * Added -prefill option * Added -cancel option * Added support for 'ansiNNN' and 'rgbNNN' colour specifications within -style and -echostyle arguments * Improved error messages (some now indicate what the wrong argument was) * Removed all uses of given/when and smartmatching for compatibility with Perl 5.38+ 0.005001 Mon Jul 17 06:54:17 2023 * Removed all uses of continue; (Thanks, Alexander!) 0.005002 Fri Feb 7 20:36:27 2025 * Worked around odd 'uninitialized' warning under timeouts (thanks Diab!) IO-Prompter-0.005002/MANIFEST000644 000765 000024 00000001452 14751352043 015610 0ustar00damianstaff000000 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 t/autoexport.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) IO-Prompter-0.005002/t/000755 000765 000024 00000000000 14751352043 014720 5ustar00damianstaff000000 000000 IO-Prompter-0.005002/README000644 000765 000024 00000002022 14751352033 015330 0ustar00damianstaff000000 000000 IO::Prompter version 0.005002 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.005002/META.yml000644 000765 000024 00000001163 14751352043 015727 0ustar00damianstaff000000 000000 --- abstract: 'Prompt for input, read it, clean it, return it.' author: - 'Damian Conway ' build_requires: ExtUtils::MakeMaker: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.70, CPAN::Meta::Converter version 2.150010' 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' match::smart: '0.01' version: '0.005002' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' IO-Prompter-0.005002/lib/000755 000765 000024 00000000000 14751352043 015223 5ustar00damianstaff000000 000000 IO-Prompter-0.005002/Makefile.PL000644 000765 000024 00000001134 14450743600 016425 0ustar00damianstaff000000 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, 'match::smart' => 0.010, }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'IO-Prompter-*' }, ); IO-Prompter-0.005002/META.json000644 000765 000024 00000002005 14751352043 016073 0ustar00damianstaff000000 000000 { "abstract" : "Prompt for input, read it, clean it, return it.", "author" : [ "Damian Conway " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.70, CPAN::Meta::Converter version 2.150010", "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", "match::smart" : "0.01" } } }, "release_status" : "stable", "version" : "0.005002", "x_serialization_backend" : "JSON::PP version 4.16" } IO-Prompter-0.005002/lib/IO/000755 000765 000024 00000000000 14751352043 015532 5ustar00damianstaff000000 000000 IO-Prompter-0.005002/lib/IO/Prompter.pm000644 000765 000024 00000401262 14751352033 017704 0ustar00damianstaff000000 000000 use 5.010; package IO::Prompter; use utf8; use warnings; no if $] >= 5.018000, warnings => 'experimental'; use strict; use Carp; use Contextual::Return qw< PUREBOOL BOOL SCALAR METHOD VOID LIST RETOBJ >; use Scalar::Util qw< openhandle looks_like_number >; use Symbol qw< qualify_to_ref >; use match::smart qw< match >; our $VERSION = '0.005002'; 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; eval { REPROMPT_YESNO: if ($opt_ref->{-menu}) { # Remember top of (possibly nested) menu... my @menu = ( $opt_ref->{-menu} ); my $top_prompt = $opt_ref->{-prompt}; $top_prompt =~ s{$MENU_MK}{$opt_ref->{-menu}{prompt}}xms; $menu[-1]{prompt} = $top_prompt; MENU: while (1) { # Track the current level... $opt_ref->{-menu_curr_level} = $menu[-1]{value_for}; # Show menu and retreive choice... $outputter_ref->(-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->(); } 1; } // do { # Supply the missing newline if requested... $outputter_ref->(-echostyle => $opt_ref->{-return}(q{})) if exists $opt_ref->{-return}; # Rethrow any other exception... my $error = $@; die $@ unless ref($error) eq 'IO::Prompter::Cancellation'; # Return failure on cancellation... return if $opt_ref->{-verbatim}; return PUREBOOL { 0 } BOOL { 0 } SCALAR { ${$error} } METHOD { defaulted => sub { 0 }, timedout => sub { 0 } }; }; # Provide default value if available and necessary... my $defaulted = 0; { no warnings 'uninitialized'; if (defined $input && $input =~ /\A\R?\Z/ && exists $opt_ref->{-def}) { $input = $opt_ref->{-def}; $defaulted = 1; } # The input line is usually chomped before being returned... if (defined $input && !$opt_ref->{-line}) { chomp $input; } } # Check for a value indicating failure... if (exists $opt_ref->{-fail} && match($input, $opt_ref->{-fail})) { $input = undef; } # Setting @ARGV is a special case; process it like a command-line... if ($opt_ref->{-argv}) { @ARGV = map { _shell_expand($_) } grep {defined} $input =~ m{ ( ' [^'\\]* (?: \\. [^'\\]* )* ' ) | ( " [^"\\]* (?: \\. [^"\\]* )* " ) | (?: ^ | \s) ( [^\s"'] \S* ) }gxms; return 1; } # "Those who remember history are enabled to repeat it"... if (defined $input and $opt_ref->{-history} ne 'NONE') { no warnings 'uninitialized'; my $history_set = $history_cache{ $opt_ref->{-history} } //= [] ; @{ $history_set } = ($input, grep { $_ ne $input } @{ $history_set }); } # If input timed out insert the default, if any... my $timedout = $in_pos == do{ no warnings; tell $in_filehandle } // 0; if ($timedout && exists $opt_ref->{-def}) { $input = $opt_ref->{-def}; $defaulted = 1; } # A defined input is a successful input... my $succeeded = defined $input; # The -yesno variants also need a 'y' to be successful... if ($opt_ref->{-yesno}{count}) { $succeeded &&= $input =~ m{\A \s* y}ixms; if ($succeeded && $opt_ref->{-yesno}{count} > 1) { my $count = --$opt_ref->{-yesno}{count}; $opt_ref->{-prompt} = @yesno_prompts ? shift(@yesno_prompts) . q{ } : $count > 1 ? qq{Please confirm $count more times } : q{Please confirm one last time } ; goto REPROMPT_YESNO; # Gasp, yes goto is the cleanest way! } } # Verbatim return doesn't do fancy tricks... if ($opt_ref->{-verbatim}) { return $input // (); } # Failure in a list context returns nothing... return if LIST && !$succeeded; # Otherwise, be context sensitive... return PUREBOOL { $_ = RETOBJ; next handler; } BOOL { $succeeded; } SCALAR { $input; } METHOD { defaulted => sub { $defaulted }, timedout => sub { return q{} if !$timedout; return "timed out after $opt_ref->{-timeout} second" . ($opt_ref->{-timeout} == 1 ? q{} : q{s}); }, }; } # Simulate a command line expansion for the -argv option... sub _shell_expand { my ($text) = @_; # Single-quoted text is literal... if ($text =~ m{\A ' (.*) ' \z}xms) { return $1; } # Everything else has shell variables expanded... my $ENV_PAT = join '|', reverse sort keys %ENV; $text =~ s{\$ ($ENV_PAT)}{$ENV{$1}}gxms; # Double-quoted text isn't globbed... if ($text =~ m{\A " (.*) " \z}xms) { return $1; } # Everything else is... return glob($text); } # No completion is the default... my $DEFAULT_COMPLETER = sub { q{} }; # Translate std constraints... my %STD_CONSTRAINT = ( positive => sub { $_ > 0 }, negative => sub { $_ < 0 }, zero => sub { $_ == 0 }, even => sub { $_ % 2 == 0 }, odd => sub { $_ % 2 != 0 }, ); # Create abbreviations... $STD_CONSTRAINT{pos} = $STD_CONSTRAINT{positive}; $STD_CONSTRAINT{neg} = $STD_CONSTRAINT{negative}; # Create antitheses... for my $constraint (keys %STD_CONSTRAINT) { my $implementation = $STD_CONSTRAINT{$constraint}; $STD_CONSTRAINT{"non$constraint"} = sub { ! $implementation->(@_) }; } # Special style specifications require decoding... sub _decode_echo { my $style = shift; # Not a special style... return $style if ref $style || $style !~ m{/}; # A slash means yes/no echoes... my ($yes, $no) = split m{/}, $style; return sub{ /y/i ? $yes : $no }; } sub _decode_echostyle { my $style = shift; # Not a special style... return $style if ref $style || $style !~ m{/}; # A slash means yes/no styles... my ($yes, $no) = split m{/}, $style; return sub{ /y/i ? $yes : $no }; } sub _decode_style { # No special prompt styles (yet)... return shift; } # Generate safe closure around active sub... sub _gen_wrapper_for { my ($arg) = @_; return ref $arg ne 'CODE' ? sub { $arg } : sub { eval { for (shift) { no warnings; return $arg->($_) // $_ } } }; } # Create recognizer... my $STD_CONSTRAINT = '^(?:' . join('|', reverse sort keys %STD_CONSTRAINT) . ')'; # Translate name constraints to implementations... sub _standardize_constraint { my ($option_type, $constraint_spec) = @_; return ("be an acceptable $option_type", $constraint_spec) if ref $constraint_spec; my @constraint_names = split /\s+/, $constraint_spec; my @constraints = map { $STD_CONSTRAINT{$_} // _opt_err('invalid',-$option_type,'"pos", "neg", "even", etc.', qq{"$_"}) } @constraint_names; return ( 'be ' . join(' and ', @constraint_names), sub { my ($compare_val) = @_; for my $constraint (@constraints) { return 0 if !$constraint->($compare_val); } return 1; } ); } # Convert args to prompt + options hash... sub _decode_args { my %option = ( -prompt => undef, -complete => $DEFAULT_COMPLETER, -must => {}, -history => 'DEFAULT', -style => sub{ q{} }, -nostyle => sub{ q{} }, -echostyle => sub{ q{} }, -echo => sub { my $char = shift; $char eq "\t" ? q{ } : $char }, -return => sub { "\n" }, ); DECODING: while (defined(my $arg = shift @_)) { if (my $type = ref $arg) { _warn( reserved => 'prompt(): Unexpected argument (' . lc($type) . ' ref) ignored' ); } else { state $already_wiped; my $redo; # The sound of one hand clapping... if ($arg =~ /^-_/) { $redo = 1; } # Non-chomping option... elsif ($arg =~ /^-line$/) { $option{-line}++; } elsif ($arg =~ /^-l/) { $option{-line}++; $redo = 1; } # The -yesno variants... elsif ($arg =~ /^-YesNo$/) { my $count = @_ && looks_like_number($_[0]) ? shift @_ : 1; $option{-yesno} = { must => { '[YN]' => qr{\A \s* [YN] }xms }, count => $count, }; } elsif ($arg =~ /^-YN/) { $option{-yesno} = { must => { '[YN]' => qr{\A \s* [YN] }xms }, count => 1, }; $redo = 2; } elsif ($arg =~ /^-yesno$/) { my $count = @_ && looks_like_number($_[0]) ? shift @_ : 1; $option{-yesno} = { must => { '[yn]' => qr{\A \s* [YN] }ixms }, count => $count, }; } elsif ($arg =~ /^-yn/) { $option{-yesno} = { must => { '[yn]' => qr{\A \s* [YN] }ixms }, count => 1, }; $redo = 2; } elsif ($arg =~ /^-Yes$/) { my $count = @_ && looks_like_number($_[0]) ? shift @_ : 1; $option{-yesno} = { must => { '[Y for yes]' => qr{\A \s* (?: [^y] | \Z) }xms }, count => $count, }; } elsif ($arg =~ /^-Y/) { $option{-yesno} = { must => { '[Y for yes]' => qr{\A \s* (?: [^y] | \Z) }xms }, count => 1, }; $redo = 1; } elsif ($arg =~ /^-yes$/) { my $count = @_ && looks_like_number($_[0]) ? shift @_ : 1; $option{-yesno} = { count => $count }; } elsif ($arg =~ /^-y/) { $option{-yesno} = { count => 1 }; $redo = 1; } # Load @ARGV... elsif ($arg =~ /^-argv$/) { $option{-argv} = 1; } elsif ($arg =~ /^-a/) { $option{-argv} = 1; $redo = 1; } # Clear screen before prompt... elsif ($arg =~ /^-wipe(first)?$/) { $option{-wipe} = $1 ? !$already_wiped : 1; $already_wiped = 1; } elsif ($arg =~ /^-w/) { $option{-wipe} = 1; $already_wiped = 1; $redo = 1; } # Specify a failure condition... elsif ($arg =~ /^-fail$/) { _opt_err('Missing', -fail, 'failure condition') if !@_; $option{-fail} = shift @_; } # Specify an immediate failure condition... elsif ($arg =~ /^-cancel/) { _opt_err('Missing', -cancel, 'cancellation condition') if !@_; $option{-cancel} = shift @_; } # Specify a file request... elsif ($arg =~ /^-f(?:ilenames?)?$/) { $option{-must}{'0: be an existing file'} = sub { -e $_[0] }; $option{-must}{'1: be readable'} = sub { -r $_[0] }; $option{-complete} = 'filenames'; } # Specify prompt echoing colour/style... elsif ($arg =~ /^-style/) { _opt_err('Missing -style specification') if !@_; my $style = _decode_style(shift @_); $option{-style} = _gen_wrapper_for($style); } # Specify input colour/style... elsif ($arg =~ /^-echostyle/) { _opt_err('Missing -echostyle specification') if !@_; my $style = _decode_echostyle(shift @_); $option{-echostyle} = _gen_wrapper_for($style); } # Specify input and output filehandles... elsif ($arg =~ /^-stdio$/) { $option{-in} = *STDIN; $option{-out} = *STDOUT; } elsif ($arg =~ /^-in$/) { $option{-in} = shift @_; } elsif ($arg =~ /^-out$/) { $option{-out} = shift @_; } # Specify integer and number return value... elsif ($arg =~ /^-integer$/) { $option{-integer} = 1; if (@_ && (ref $_[0] || $_[0] =~ $STD_CONSTRAINT)) { my ($errmsg, $constraint) = _standardize_constraint('integer',shift); $option{-must}{$errmsg} = $constraint; } } elsif ($arg =~ /^-num(?:ber)?$/) { $option{-number} = 1; if (@_ && (ref $_[0] || $_[0] =~ $STD_CONSTRAINT)) { my ($errmsg, $constraint) = _standardize_constraint('number',shift); $option{-must}{$errmsg} = $constraint; } } elsif ($arg =~ /^-i/) { $option{-integer} = 1; $redo = 1; } elsif ($arg =~ /^-n/) { $option{-number} = 1; $redo = 1; } # Specify void context is okay... elsif ($arg =~ /^-void$/) { $option{-void} = 1; } # Specify verbatim return value... elsif ($arg =~ /^-verb(?:atim)?$/) { $option{-verbatim} = 1; } elsif ($arg =~ /^-v/) { $option{-verbatim} = 1; $redo = 1;} # Specify single character return... elsif ($arg =~ /^-sing(?:le)?$/) { $option{-single} = 1; } elsif ($arg =~ /^-[s1]/) { $option{-single} = 1; $redo = 1; } # Specify a default... elsif ($arg =~ /^-DEF(?:AULT)?/) { _opt_err('Missing', '-DEFAULT', 'string') if !@_; $option{-def} = shift @_; $option{-def_nocheck} = 1; _opt_err('Invalid', '-DEFAULT', 'string', 'reference') if ref($option{-def}); } elsif ($arg =~ /^-def(?:ault)?/) { _opt_err('Missing', '-default', 'string') if !@_; $option{-def} = shift @_; _opt_err('Invalid', '-default', 'string', 'reference') if ref($option{-def}); } elsif ($arg =~ /^-d(.+)$/) { $option{-def} = $1; } # Specify a timeout... elsif ($arg =~ /^-t(\d+)/) { $option{-timeout} = $1; $arg =~ s{\d+}{}xms; $redo = 1; } elsif ($arg =~ /^-timeout$/) { _opt_err('Missing', -timeout, 'number of seconds') if !@_; $option{-timeout} = shift @_; _opt_err('Invalid', -timeout,'number of seconds', qq{'$option{-timeout}'}) if !looks_like_number($option{-timeout}); } # Specify a set of input constraints... elsif ($arg =~ /^-g.*/) { _opt_err('Missing', -guarantee, 'input restriction') if !@_; my $restriction = shift @_; my $restriction_type = ref $restriction; $option{-must}{'be a valid input'} = $restriction; # Hashes restrict input to their keys... if ($restriction_type eq 'HASH') { $restriction_type = 'ARRAY'; $restriction = [ keys %{$restriction} ]; } # Arrays of strings matched (and completed) char-by-char... if ($restriction_type eq 'ARRAY') { my @restrictions = @{$restriction}; $option{-guarantee} = '\A(?:' . join('|', map { join(q{}, map { "(?:\Q$_\E" } split(q{}, $_)) . ')?' x length($_) } @restrictions) . ')\z' ; if ($option{-complete} == $DEFAULT_COMPLETER) { $option{-complete} = \@restrictions; } } # Regexes matched as-is... elsif ($restriction_type eq 'Regexp') { $option{-guarantee} = $restriction; } else { _opt_err( 'Invalid', -guarantee, 'array or hash reference, or regex' ); } } # Specify a set of key letters... elsif ($arg =~ '-keyletters_implement') { # Extract all keys and default keys... my @keys = ($option{-prompt} =~ m{$KL_EXTRACT}gxms); # Convert default to a -default... my @defaults = ($option{-prompt} =~ m{$KL_DEF_EXTRACT}gxms); if (@defaults > 1) { _warn( ambiguous => "prompt(): -keyletters found too many defaults" ) } elsif (@defaults) { push @_, -default => $defaults[0]; } # Convert key letters to a -guarantee... @keys = ( map({uc} @keys), map({lc} @keys) ); if (@defaults == 1) { push @keys, q{}; } push @_, -guarantee => \@keys; } elsif ($arg =~ /^-key(?:let(?:ter)?)(?:s)?/) { push @_, '-keyletters_implement'; } elsif ($arg =~ /^-k/) { push @_, '-keyletters_implement'; $redo = 1; } # Specify a set of return constraints... elsif ($arg =~ /^-must$/) { _opt_err('Missing', -must, 'constraint hash') if !@_; my $must = shift @_; _opt_err('Invalid', -must, 'hash reference') if ref($must) ne 'HASH'; for my $errmsg (keys %{$must}) { $option{-must}{$errmsg} = $must->{$errmsg}; } } # Specify a history set... elsif ($arg =~ /^-history/) { $option{-history} = @_ && $_[0] !~ /^-/ ? shift @_ : undef; _opt_err('Invalid', -history, 'history set name', qq{'$option{-history}'}) if ref($option{-history}); } elsif ($arg =~ /^-h(.*)/) { $option{-history} = length($1) ? $1 : undef; } # Specify completions... elsif ($arg =~ /^-comp(?:lete)?/) { _opt_err('Missing', -complete, 'completions') if !@_; my $comp_spec = shift @_; my $comp_type = ref($comp_spec) || $comp_spec || '???'; if ($comp_type =~ m{\A(?: file\w* | dir\w* | ARRAY | HASH | CODE )\Z}xms) { $option{-complete} = $comp_spec; } else { _opt_err( 'Invalid', -complete, '"filenames", "dirnames", or reference to array, hash, or subroutine'); } } # Specify what to echo when a character is keyed... elsif ($arg =~ /^-(echo|ret(?:urn)?)$/) { my $flag = $1 eq 'echo' ? '-echo' : '-return'; if ($flag eq '-echo' && !eval { no warnings 'deprecated'; require Term::ReadKey }) { _warn( bareword => "Warning: next input will be in plaintext\n"); } my $arg = @_ && $_[0] !~ /^-/ ? shift(@_) : $flag eq '-echo' ? q{} : qq{\n}; $option{$flag} = _gen_wrapper_for(_decode_echo($arg)); } elsif ($arg =~ /^-e(.*)/) { if (!eval { no warnings 'deprecated'; require Term::ReadKey }) { _warn( bareword => "Warning: next input will be in plaintext\n"); } my $arg = $1; $option{-echo} = _gen_wrapper_for(_decode_echo($arg)); } elsif ($arg =~ /^-r(.+)/) { my $arg = $1; $option{-return} = _gen_wrapper_for(_decode_echo($arg)); } elsif ($arg =~ /^-r/) { $option{-return} = sub{ "\n" }; } # Specify an initial input... elsif ($arg =~ /^-prefill/) { _opt_err('Missing', '-prefill', 'string') if !@_; $option{-prefill} = shift @_; _opt_err('Invalid', '-prefill', 'string', 'reference') if ref($option{-prefill}); } # Explicit prompt replaces implicit prompts... elsif ($arg =~ /^-prompt$/) { _opt_err('Missing', '-prompt', 'prompt string') if !@_; $option{-prompt} = shift @_; _opt_err('Invalid', '-prompt', 'string', 'reference') if ref($option{-prompt}); } elsif ($arg =~ /^-p(\S*)$/) { $option{-prompt} = $1; } # Menus inject a placeholder in the prompt string... elsif ($arg =~ /^-menu$/) { _opt_err('Missing', '-menu', 'menu specification') if !@_; $option{-menu} = ref $_[0] ? shift(@_) : \shift(@_); $option{-prompt} .= $MENU_MK; $option{-def_nocheck} = 1; } # A monitoring sub is called on every input character... elsif ($arg =~ /^-monitor/) { _opt_err('Missing', '-monitor', 'a monitor subref') if !@_ || ref $_[0] ne 'CODE'; $option{-monitor} = shift(@_); } # Anything else of the form '-...' is a misspelt option... elsif ($arg =~ /^-\w+$/) { _warn(misc => "prompt(): Unknown option $arg ignored"); } # Anything else is part fo the prompt... else { $option{-prompt} .= $arg; } # Handle option bundling... redo DECODING if $redo && $arg =~ s{\A -.{$redo} (?=.)}{-}xms; } } # Precompute top-level menu, if menuing... if (exists $option{-menu}) { $option{-menu} = _build_menu($option{-menu}, undef, $option{-number}||$option{-integer} ); } # Handle return magic on -single... if (defined $option{-single} && length($option{-echo}('X')//'echoself')) { $option{-return} //= sub{ "\n" }; } # Adjust prompt as necessary... if ($option{-argv}) { my $progname = $option{-prompt} // $0; $progname =~ s{^.*/}{}xms; my $HINT = '[enter command line args here]'; $option{-prompt} = "> $progname $HINT\r> $progname "; $option{-complete} = 'filenames'; my $not_first; $option{-echo} = sub{ my $char = shift; $option{-prompt} = "> $progname "; # Sneaky resetting to handle completions return $char if $not_first++; return "\r> $progname " . (q{ } x length $HINT) . "\r> $progname $char"; } } elsif (!defined $option{-prompt}) { $option{-prompt} = '> '; } elsif ($option{-prompt} =~ m{ \S \z}xms) { # If prompt doesn't end in whitespace, make it so... $option{-prompt} .= ' '; } elsif ($option{-prompt} =~ m{ (.*) \n \z}xms) { # If prompt ends in a newline, remove it... $option{-prompt} = $1; } # Steal history set name if -h given without a specification... $option{-history} //= $option{-prompt}; # Verify any default satisfies any constraints... if (exists $option{-def} && !$option{-def_nocheck}) { if (!_verify_input_constraints(\q{},undef,undef,\%option)) { _warn( misc => 'prompt(): -default value does not satisfy -must constraints' ); } } return \%option; } #====[ Error Handlers ]========================================= sub _opt_err { my ($problem, $option, $expectation, $found) = @_; if (@_ > 3) { Carp::croak "prompt(): $problem value for $option (expected $expectation, but found $found)"; } else { Carp::croak "prompt(): $problem value for $option (expected $expectation)"; } } sub _warn { my ($category, @message) = @_; return if !warnings::enabled($category); my $message = join(q{},@message); warn $message =~ /\n$/ ? $message : Carp::shortmess($message); } #====[ Utility subroutines ]==================================== # Return the *ARGV filehandle, "magic-opening" it if necessary... sub _open_ARGV { if (!openhandle \*ARGV) { $ARGV = shift @ARGV // '-'; open *ARGV or Carp::croak(qq{prompt(): Can't open *ARGV: $!}); } return \*ARGV; } my $INTEGER_PAT = qr{ \A \s*+ [+-]?+ \d++ (?: [Ee] \+? \d+ )? \s*+ \Z }xms; my $NUMBER_PAT = qr{ \A \s*+ [+-]?+ (?: \d++ (?: [.,] \d*+ )? | [.,] \d++ ) (?: [eE] [+-]?+ \d++ )? \s*+ \Z }xms; # Verify interactive constraints... sub _verify_input_constraints { my ($input_ref, $local_fake_input_ref, $outputter_ref, $opt_ref, $extras) = @_; # Use default if appropriate (but short-circuit checks if -DEFAULT set)... my $input = ${$input_ref}; if (${$input_ref} =~ m{^\R?$}xms && exists $opt_ref->{-def}) { return 1 if $opt_ref->{-def_nocheck}; $input = $opt_ref->{-def} } chomp $input; my $failed; # Integer constraint is hard-coded... if ($opt_ref->{-integer} && $input !~ $INTEGER_PAT) { $failed = $opt_ref->{-prompt} . "(must be an integer) "; } # Numeric constraint is hard-coded... if (!$failed && $opt_ref->{-number} && $input !~ $NUMBER_PAT) { $failed = $opt_ref->{-prompt} . "(must be a number) "; } # Sort and clean up -must list... my $must_ref = $opt_ref->{-must} // {}; my @must_keys = sort keys %{$must_ref}; my %clean_key_for = map { $_ => (/^\d+[.:]?\s*(.*)/s ? $1 : $_) } @must_keys; my @must_kv_list = map { $clean_key_for{$_} => $must_ref->{$_} } @must_keys; # Combine -yesno and -must constraints... my %constraint_for = ( %{ $extras // {} }, %{ $opt_ref->{-yesno}{must} // {} }, @must_kv_list, ); my @constraints = ( keys %{ $extras // {} }, keys %{ $opt_ref->{-yesno}{must} // {} }, @clean_key_for{@must_keys}, ); # User-specified constraints... if (!$failed && keys %constraint_for) { CONSTRAINT: for my $msg (@constraints) { my $constraint = $constraint_for{$msg}; next CONSTRAINT if eval { no warnings; local $_ = $input; match($input, $constraint); }; $failed = $msg =~ m{\A [[:upper:]] }xms ? "$msg " : $msg =~ m{\A \W }xms ? $opt_ref->{-prompt} . "$msg " : $opt_ref->{-prompt} . "(must $msg) " ; last CONSTRAINT; } } # If any constraint not satisfied... if ($failed) { # Return failure if not actually prompting at the moment... return 0 if !$outputter_ref; # Redraw post-menu prompt with failure message appended... $failed =~ s{.*$MENU_MK}{}xms; $outputter_ref->(-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 (exists $opt_ref->{-cancel}) { for my $nextchar (split q{}, $input) { die bless \$input, 'IO::Prompter::Cancellation' if match($nextchar, $opt_ref->{-cancel}); } } if (defined $input) { _verify_input_constraints( \$input, \$local_fake_input, $outputter_ref, $opt_ref, $extra_constraints ); } return defined $input && $opt_ref->{-single} ? substr($input, 0, 1) : $input; } else { return; } } } } sub _autoflush { my ($fh) = @_; my $prev_selected = select $fh; $| = 1; select $prev_selected; return; } sub _simulate_typing { state $TYPING_SPEED = 0.07; # seconds per character select undef, undef, undef, rand $TYPING_SPEED; } sub _term_width { my ($term_width) = eval { no warnings 'deprecated'; Term::ReadKey::GetTerminalSize(\*STDERR) }; return $term_width // $DEFAULT_TERM_WIDTH; } sub _wipe_line { return qq{\r} . q{ } x (_term_width()-1) . qq{\r}; } # Convert a specification into a list of possible completions... sub _current_completions_for { my ($input_text, $opt_ref) = @_; my $completer = $opt_ref->{-complete}; # Isolate the final whitespace-separated word... my ($prefix, $lastword) = $input_text =~ m{ (?| ^ (.*\s+) (.*) | ^ () (.*) ) }xms; # Find candidates... my @candidates; for my $completer_type (ref($completer) || $completer // q{}) { # If completer is sub, recursively call it with input words... if ($completer_type eq 'CODE') { ($prefix, @candidates) = _current_completions_for( $input_text, { %{$opt_ref}, -complete => $completer->(split /\s+/, $input_text, -1) } ); } # If completer is array, grep the appropriate elements... elsif ($completer_type eq 'ARRAY') { @candidates = grep { /\A\Q$lastword\E/ } @{$completer}; } # If completer is hash, grep the appropriate keys... elsif ($completer_type eq 'HASH') { @candidates = grep { /\A\Q$lastword\E/ } keys %{$completer}; } # If completer is 'file...', glob up the appropriate filenames... elsif ($completer_type eq /^file\w*$/) { @candidates = glob($lastword.'*'); } # If completer is 'dir...', glob up the appropriate directories... elsif ($completer_type eq /^dir\w*$/) { @candidates = grep {-d} glob($lastword.'*'); } } chomp @candidates; return ($prefix, @candidates); } sub _current_history_for { my ($prefix, $opt_ref) = @_; my $prefix_len = length($prefix); return q{}, map { /\A (.*?) \R \Z/x ? $1 : $_ } grep { substr($_,0,$prefix_len) eq $prefix } @{ $history_cache{$opt_ref->{-history}} }; } sub _longest_common_prefix_for { my $prefix = shift @_; for my $comparison (@_) { ($comparison ^ $prefix) =~ m{ \A (\0*) }xms; my $common_length = length($1); return q{} if !$common_length; $prefix = substr($prefix, 0, $common_length); } return $prefix; } sub _display_completions { my ($input, @candidates) = @_; return q{} if @candidates <= 1; # How big is each field in the table? my $field_width = _term_width() / $COMPLETE_DISPLAY_FIELDS - $COMPLETE_DISPLAY_GAP; # Crop the possibilities intelligently to that width... for my $candidate (@candidates) { substr($candidate, 0, length($input)) =~ s{ \A .* [/\\] }{}xms; $candidate = sprintf "%-*s", $field_width, substr($candidate,0,$field_width); } # Collect them into rows... my $display = "\n"; my $gap = q{ } x $COMPLETE_DISPLAY_GAP; while (@candidates) { $display .= $gap . join($gap, splice(@candidates, 0, $COMPLETE_DISPLAY_FIELDS)) . "\n"; } return $display; } sub _generate_unbuffered_reader_from { my ($in_fh, $outputter_ref, $opt_ref) = @_; my $has_readkey = eval { no warnings 'deprecated'; require Term::ReadKey }; # If no per-character reads, fall back on buffered input... if (!-t $in_fh || !$has_readkey) { return _generate_buffered_reader_from($in_fh, $outputter_ref, $opt_ref); } # Adapt to local control characters... my %ctrl = eval { Term::ReadKey::GetControlChars($in_fh) }; delete $ctrl{$_} for grep { $ctrl{$_} eq "\cA" } keys %ctrl; $ctrl{EOF} //= "\4"; $ctrl{INTERRUPT} //= "\3"; $ctrl{ERASE} //= $^O eq 'MSWin32' ? "\10" : "0177"; my $ctrl = join '|', values %ctrl; my $VERBATIM_KEY = $ctrl{QUOTENEXT} // $DEFAULT_VERBATIM_KEY; # Translate timeout for ReadKey (with 32-bit MAXINT workaround for Windows)... my $timeout = !defined $opt_ref->{-timeout} ? 0x7FFFFFFF # 68 years : $opt_ref->{-timeout} == 0 ? -1 : $opt_ref->{-timeout} ; return sub { my ($extra_constraints) = @_; # Short-circuit on unreadable filehandle... return if !openhandle($in_fh); # Set up direct reading, and prepare to clean up on abnormal exit... Term::ReadKey::ReadMode('raw', $in_fh); my $prev_SIGINT = $SIG{INT}; local $SIG{INT} = sub { return if defined $prev_SIGINT && $prev_SIGINT eq 'IGNORE'; Term::ReadKey::ReadMode('restore', $in_fh); exit(1) if !defined $prev_SIGINT || $prev_SIGINT eq 'DEFAULT'; { package main; no strict 'refs'; $prev_SIGINT->() } }; # Set up local faked input, if any... my $local_fake_input; my $orig_fake_input; if (defined $fake_input && length($fake_input) > 0) { $fake_input =~ s{ \A (.*) \R? }{}xm; $orig_fake_input = $local_fake_input = $1; } my $input = exists $opt_ref->{-prefill} ? $opt_ref->{-prefill} : q{}; if (exists $opt_ref->{-prefill}) { if (exists $opt_ref->{-monitor}) { my %opts = ( -cursor_pos => length($input), -prompt => $opt_ref->{-prompt}, -style => $opt_ref->{-style}->(), -echostyle => $opt_ref->{-echostyle}->(), ); my $input_copy = $input; eval { $opt_ref->{-monitor}->($input_copy, \%opts) }; } $outputter_ref->( -style => $opt_ref->{-style}, _wipe_line(), $opt_ref->{-prompt}); $outputter_ref->( -echostyle => join(q{}, map { $opt_ref->{-echo}($_) } $input =~ m/\X/g) ); } my $insert_offset = 0; INPUT: while (1) { state $prev_was_verbatim = 0; state $completion_level = 0; state $completion_type = q{}; # Get next character entered... my $next = Term::ReadKey::ReadKey($timeout, $in_fh); # Check for cancellation... if (exists $opt_ref->{-cancel} && match($next, $opt_ref->{-cancel})) { Term::ReadKey::ReadMode('restore', $in_fh); die bless \$input, 'IO::Prompter::Cancellation'; } # Finished with completion mode? if (($next//q{}) !~ m{ $COMPLETE_INIT | $COMPLETE_CYCLE }xms) { $completion_level = 0; $completion_type = q{}; } # Are we faking input? my $faking = defined $local_fake_input; # If not EOF... if (defined $next) { # Remember where we were parked... my $prev_insert_offset = $insert_offset; # Handle interrupts... if ($next eq $ctrl{INTERRUPT}) { $SIG{INT}(); next INPUT; } # Handle verbatim quoter... elsif (!$prev_was_verbatim && $next eq $VERBATIM_KEY) { $prev_was_verbatim = 1; next INPUT; } # Handle completions... elsif (!$prev_was_verbatim && ( $next =~ $COMPLETE_INIT || $completion_level > 0 && $next =~ $COMPLETE_CYCLE ) ) { state @completion_list; # ...all candidates for completion state @completion_ring; # ..."next" candidate cycle state $completion_ring_first; # ...special case first time state $completion_prefix; # ...skipped before completing # Track completion type and level (switch if necessary)... if ($next =~ $COMPLETE_INIT && index($completion_type, $next) < 0) { $completion_type = index($COMPLETE_KEY, $next) >= 0 ? $COMPLETE_KEY : $COMPLETE_HIST; $completion_level = 1; } else { $completion_level++; } # If starting completion, cache completions... if ($completion_level == 1) { ($completion_prefix, @completion_list) = index($COMPLETE_KEY, $next) >= 0 ? _current_completions_for($input, $opt_ref) : _current_history_for($input, $opt_ref); @completion_ring = (@completion_list, q{}); $completion_ring_first = 1; } # Can only complete if there are completions to be had... if (@completion_list) { # Select the appropriate mode... my $mode = $COMPLETE_MODE{$completion_type}[$completion_level-1] // $COMPLETE_MODE{$completion_type}[-1]; # 'longest mode' finds longest consistent prefix... if ($mode =~ /longest/) { $input = $completion_prefix . _longest_common_prefix_for(@completion_list); } # 'full mode' suggests next full match... elsif ($mode =~ /full/) { if (!$completion_ring_first) { if ($next eq $COMPLETE_PREV) { unshift @completion_ring, pop @completion_ring; } else { push @completion_ring, shift @completion_ring; } } $input = $completion_prefix . $completion_ring[0]; $completion_ring_first = 0; } # 'list mode' lists all possibilities... my $list_display = $mode =~ /list/ ? _display_completions($input, @completion_list) : q{}; # Update prompt with selected completion... $outputter_ref->( -style => $list_display, _wipe_line(), $opt_ref->{-prompt}, $input ); # If last completion was unique choice, completed... if (@completion_list <= 1) { $completion_level = 0; } } next INPUT; } # Handle erasures (including pushbacks if faking)... elsif (!$prev_was_verbatim && $next eq $ctrl{ERASE}) { if (!length $input) { # Do nothing... } elsif ($insert_offset) { # Can't erase past start of input... next INPUT if $insert_offset >= length($input); # Erase character just before cursor... substr($input, -$insert_offset-1, 1, q{}); # Redraw... my $input_pre = substr($input.' ',0,length($input)-$insert_offset+1); my $input_post = substr($input.' ',length($input)-$insert_offset); my $display_pre = join q{}, map { $opt_ref->{-echo}($_) } $input_pre =~ m/\X/g; my $display_post = join q{}, map { $opt_ref->{-echo}($_) } $input_post =~ m/\X/g; $outputter_ref->( -echostyle => "\b" x length($display_pre) . join(q{}, map { $opt_ref->{-echo}($_) } $input =~ m/\X/g) . q{ } x length($opt_ref->{-echo}(q{ })) . "\b" x length($display_post) ); } else { my $erased = substr($input, -1, 1, q{}); if ($faking) { substr($local_fake_input,0,0,$erased); } $outputter_ref->( -nostyle => map { $_ x (length($opt_ref->{-echo}($_)//'X')) } "\b", ' ', "\b" ); } next INPUT; } # Handle EOF (including cancelling any remaining fake input)... elsif (!$prev_was_verbatim && $next eq $ctrl{EOF}) { Term::ReadKey::ReadMode('restore', $in_fh); close $in_fh; undef $fake_input; return length($input) ? $input : undef; } # Handle escape from faking... elsif (!$prev_was_verbatim && $faking && $next eq $FAKE_ESC) { my $lookahead = Term::ReadKey::ReadKey(0, $in_fh); # Two implies the current faked line is deferred... if ($lookahead eq $FAKE_ESC) { $fake_input =~ s{ \A }{$orig_fake_input\n}xm; } # Only one implies the current faked line is replaced... else { $in_fh->ungetc(ord($lookahead)); } undef $local_fake_input; $faking = 0; next INPUT; } # Handle returns... elsif (!$prev_was_verbatim && $next =~ /\A\R\z/) { # Complete faked line, if faked input incomplete... if ($faking && length($local_fake_input)) { for ($local_fake_input =~ m/\X/g) { _simulate_typing(); $outputter_ref->(-echostyle => $opt_ref->{-echo}($_)); } $input .= $local_fake_input; } # Add newline to the accumulated input string... $input .= $next; # Check that input satisfied any constraints... _verify_input_constraints( \$input, \$local_fake_input, $outputter_ref, $opt_ref, $extra_constraints, ); # Echo a default value if appropriate... if ($input =~ m{\A\R?\Z}xms && defined $opt_ref->{-def}) { my $def_val = $opt_ref->{-def}; # Try to find the key, for a menu... if (exists $opt_ref->{-menu_curr_level}) { for my $key ( keys %{$opt_ref->{-menu_curr_level}}) { if (match($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 or cancelled... if (!defined $next && length($input) == 0 || exists $opt_ref->{-cancel} && match($next, $opt_ref->{-cancel})) { return if $opt_ref->{-verbatim}; return PUREBOOL { 0 } BOOL { 0 } SCALAR { undef } METHOD { defaulted => sub { 0 }, timedout => sub { 0 } }; } # Otherwise supply a final newline if necessary... if ( $opt_ref->{-single} && exists $opt_ref->{-return} && $input !~ /\A\R\z/ ) { $outputter_ref->(-echostyle => $opt_ref->{-return}(q{})); } return $input; } } continue { # Perform monitor (if any) and redraw prompt (if required)... if ($opt_ref->{-monitor}) { my %opts = ( -cursor_pos => length($input) - $insert_offset, -prompt => $opt_ref->{-prompt}, -style => $opt_ref->{-style}->(), -echostyle => $opt_ref->{-echostyle}->(), ); my $input_copy = $input; my $output_pos = $outputter_ref->(-tell); if (!defined eval { $opt_ref->{-monitor}->($input_copy, \%opts) } || $output_pos != $outputter_ref->(-tell)) { my $input_pre = substr($input.' ',0,length($input)-$insert_offset+1); my $input_post = substr($input.' ',length($input)-$insert_offset); my $display_pre = join q{}, map { $opt_ref->{-echo}($_) } $input_pre =~ m/\X/g; my $display_post = join q{}, map { $opt_ref->{-echo}($_) } $input_post =~ m/\X/g; $outputter_ref->( -style => $opt_ref->{-style}, _wipe_line(), $opt_ref->{-prompt}); $outputter_ref->( -echostyle => join(q{}, map { $opt_ref->{-echo}($_) } $input =~ m/\X/g) . "\b" x (length($display_post)-1) ); } } } } } # Build a menu... sub _build_menu { my ($source_ref, $initial_prompt, $is_numeric) = @_; my $prompt = ($initial_prompt//q{}) . qq{\n}; my $final = q{}; my %value_for; my %key_for; my @selectors; my $source_type = ref $source_ref; if ($source_type eq 'HASH') { my @sorted_keys = sort(keys(%{$source_ref})); @selectors = $is_numeric ? (1..@sorted_keys) : ('a'..'z','A'..'Z'); @key_for{@selectors} = @sorted_keys; @value_for{@selectors} = @{$source_ref}{@sorted_keys}; $source_ref = \@sorted_keys; } elsif ($source_type eq 'SCALAR') { $source_ref = [ split "\n", ${$source_ref} ]; } my @source = @{$source_ref}; @selectors = $is_numeric ? (1..@source) : ('a'..'z','A'..'Z'); if (!keys %value_for) { @value_for{@selectors} = @source; } ITEM: for my $tag (@selectors) { my $item = shift(@source) // last ITEM; 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], italic => [qw], blink => [qw], reverse => [qw], concealed => [qw], reset => [qw], bright_ => [qw< bright\s+ vivid\s+ >], red => [qw< scarlet vermilion crimson ruby cherry cerise cardinal carmine burgundy claret chestnut copper garnet geranium russet salmon titian coral cochineal rose cinnamon ginger gules >], yellow => [qw< gold golden lemon cadmium daffodil mustard primrose tawny amber aureate canary champagne citrine citron cream goldenrod honey straw >], green => [qw< olive jade pea emerald lime chartreuse forest sage vert >], cyan => [qw< aqua aquamarine teal turquoise ultramarine >], blue => [qw< azure cerulean cobalt indigo navy sapphire >], magenta => [qw< amaranthine amethyst lavender lilac mauve mulberry orchid periwinkle plum pomegranate violet purple aubergine cyclamen fuchsia modena puce purpure >], black => [qw< charcoal ebon ebony jet obsidian onyx raven sable slate >], white => [qw< alabaster ash chalk ivory milk pearl silver argent >], ); # Back-mapping to standard terms... my %normalize = map { join('|', map { "$_\\b" } reverse sort @{$synonyms{$_}}) => $_ } keys %synonyms; my $BACKGROUND = qr{ (\S+) \s+ (?: behind | beneath | below | under(?:neath)? )\b | \b (?:upon|over|on) \s+ (?:an?)? \s+ (.*?) \s+ (?:background|bg|field) \b | \b (?:upon\s+ | over\s+ | (?:(on|upon|over)\s+a\s+)? (?:background|bg|field) \s+ (?:of\s+|in\s+)? | on\s+) (\S+) }ixms; # Convert a description to ANSI colour codes... sub _stylize { my $spec = shift // q{}; # Handle arrays and hashes as args... if (ref($spec) eq 'ARRAY') { $spec = join q{ }, @{$spec}; } elsif (ref($spec) eq 'HASH') { $spec = join q{ }, keys %{$spec}; } # Ignore punctuation... $spec =~ s/[^\w\s]//g; # Handle backgrounds... $spec =~ s/$BACKGROUND/on_$+/g; # Apply standard translations... for my $pattern (keys %normalize) { $spec =~ s{\b(on_|\b) $pattern}{($1//q{}).$normalize{$pattern}}geixms; } # Ignore anything unknown... $spec =~ s{((?:on_)?(?:(ansi\d+|rgb\d+)|(\S+)))}{ $2 || exists $synonyms{$3} ? $1 : q{} }gxmse; # Build ANSI terminal codes around text... my $raw_text = join q{}, @_; my ($prews, $text, $postws) = $raw_text =~ m{\A (\s*) (.*?) (\s*) \Z}xms; my @style = split /\s+/, $spec; return $prews . ( @style ? Term::ANSIColor::colored(\@style, $text) : $text ) . $postws; } # Build a subroutine that prints printable chars to the specified filehandle... sub _std_printer_to { my ($out_filehandle, $opt_ref) = @_; no strict 'refs'; _autoflush($out_filehandle); if (eval { require Term::ANSIColor}) { return sub { my $style = shift; return tell($out_filehandle) if $style eq -tell; my @loc = (@_); s{\e}{^}gxms for @loc; print {$out_filehandle} _stylize($opt_ref->{$style}(@loc), @loc); }; } else { return sub { my $style = shift; return tell($out_filehandle) if $style eq -tell; 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.005002 =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 subroutine does not return a string; it returns an object with overloaded string and boolean conversions. This object B> evaluates true in boolean contexts, unless the read operation actually failed. This means that the object evaluates true I See L<"Returning raw data"> to turn off this (occasionally counter-intuitive) behaviour. =back =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('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 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 -cancel=>SPEC Immediately fail if input char smartmatches value -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 completed 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 -monitor=>SUBREF Specify a sub to be called on every character input -n -num[ber][=>SPEC] Accept only valid numbers (that smartmatch SPEC) -out=>HANDLE Prompt to specified handle -prefill=>STR Start with the specified string pre-entered -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) -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 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 Prebound options You can also ask IO::Prompter to export modified versions of C with zero or more options prebound. For example, you can request an C subroutine that acts exactly like C but has the C<- yn> option pre-specified, or a C subroutine that is C 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, 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 >> 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 sometmes maps everything back to the standard eight ANSI text colours and seven ANSI text styles, all of the above may 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