| package Term::UI; |
| |
| use Carp; |
| use Params::Check qw[check allow]; |
| use Term::ReadLine; |
| use Locale::Maketext::Simple Style => 'gettext'; |
| use Term::UI::History; |
| |
| use strict; |
| |
| BEGIN { |
| use vars qw[$VERSION $AUTOREPLY $VERBOSE $INVALID]; |
| $VERBOSE = 1; |
| $VERSION = '0.30'; |
| $INVALID = loc('Invalid selection, please try again: '); |
| } |
| |
| push @Term::ReadLine::Stub::ISA, __PACKAGE__ |
| unless grep { $_ eq __PACKAGE__ } @Term::ReadLine::Stub::ISA; |
| |
| |
| =pod |
| |
| =head1 NAME |
| |
| Term::UI - Term::ReadLine UI made easy |
| |
| =head1 SYNOPSIS |
| |
| use Term::UI; |
| use Term::ReadLine; |
| |
| my $term = Term::ReadLine->new('brand'); |
| |
| my $reply = $term->get_reply( |
| prompt => 'What is your favourite colour?', |
| choices => [qw|blue red green|], |
| default => 'blue', |
| ); |
| |
| my $bool = $term->ask_yn( |
| prompt => 'Do you like cookies?', |
| default => 'y', |
| ); |
| |
| |
| my $string = q[some_command -option --no-foo --quux='this thing']; |
| |
| my ($options,$munged_input) = $term->parse_options($string); |
| |
| |
| ### don't have Term::UI issue warnings -- default is '1' |
| $Term::UI::VERBOSE = 0; |
| |
| ### always pick the default (good for non-interactive terms) |
| ### -- default is '0' |
| $Term::UI::AUTOREPLY = 1; |
| |
| ### Retrieve the entire session as a printable string: |
| $hist = Term::UI::History->history_as_string; |
| $hist = $term->history_as_string; |
| |
| =head1 DESCRIPTION |
| |
| C<Term::UI> is a transparent way of eliminating the overhead of having |
| to format a question and then validate the reply, informing the user |
| if the answer was not proper and re-issuing the question. |
| |
| Simply give it the question you want to ask, optionally with choices |
| the user can pick from and a default and C<Term::UI> will DWYM. |
| |
| For asking a yes or no question, there's even a shortcut. |
| |
| =head1 HOW IT WORKS |
| |
| C<Term::UI> places itself at the back of the C<Term::ReadLine> |
| C<@ISA> array, so you can call its functions through your term object. |
| |
| C<Term::UI> uses C<Term::UI::History> to record all interactions |
| with the commandline. You can retrieve this history, or alter |
| the filehandle the interaction is printed to. See the |
| C<Term::UI::History> manpage or the C<SYNOPSIS> for details. |
| |
| =head1 METHODS |
| |
| =head2 $reply = $term->get_reply( prompt => 'question?', [choices => \@list, default => $list[0], multi => BOOL, print_me => "extra text to print & record", allow => $ref] ); |
| |
| C<get_reply> asks a user a question, and then returns the reply to the |
| caller. If the answer is invalid (more on that below), the question will |
| be reposed, until a satisfactory answer has been entered. |
| |
| You have the option of providing a list of choices the user can pick from |
| using the C<choices> argument. If the answer is not in the list of choices |
| presented, the question will be reposed. |
| |
| If you provide a C<default> answer, this will be returned when either |
| C<$AUTOREPLY> is set to true, (see the C<GLOBAL VARIABLES> section further |
| below), or when the user just hits C<enter>. |
| |
| You can indicate that the user is allowed to enter multiple answers by |
| toggling the C<multi> flag. Note that a list of answers will then be |
| returned to you, rather than a simple string. |
| |
| By specifying an C<allow> hander, you can yourself validate the answer |
| a user gives. This can be any of the types that the Params::Check C<allow> |
| function allows, so please refer to that manpage for details. |
| |
| Finally, you have the option of adding a C<print_me> argument, which is |
| simply printed before the prompt. It's printed to the same file handle |
| as the rest of the questions, so you can use this to keep track of a |
| full session of Q&A with the user, and retrieve it later using the |
| C<< Term::UI->history_as_string >> function. |
| |
| See the C<EXAMPLES> section for samples of how to use this function. |
| |
| =cut |
| |
| sub get_reply { |
| my $term = shift; |
| my %hash = @_; |
| |
| my $tmpl = { |
| default => { default => undef, strict_type => 1 }, |
| prompt => { default => '', strict_type => 1, required => 1 }, |
| choices => { default => [], strict_type => 1 }, |
| multi => { default => 0, allow => [0, 1] }, |
| allow => { default => qr/.*/ }, |
| print_me => { default => '', strict_type => 1 }, |
| }; |
| |
| my $args = check( $tmpl, \%hash, $VERBOSE ) |
| or ( carp( loc(q[Could not parse arguments]) ), return ); |
| |
| |
| ### add this to the prompt to indicate the default |
| ### answer to the question if there is one. |
| my $prompt_add; |
| |
| ### if you supplied several choices to pick from, |
| ### we'll print them separately before the prompt |
| if( @{$args->{choices}} ) { |
| my $i; |
| |
| for my $choice ( @{$args->{choices}} ) { |
| $i++; # the answer counter -- but humans start counting |
| # at 1 :D |
| |
| ### so this choice is the default? add it to 'prompt_add' |
| ### so we can construct a "foo? [DIGIT]" type prompt |
| $prompt_add = $i if (defined $args->{default} and $choice eq $args->{default}); |
| |
| ### create a "DIGIT> choice" type line |
| $args->{print_me} .= sprintf "\n%3s> %-s", $i, $choice; |
| } |
| |
| ### we listed some choices -- add another newline for |
| ### pretty printing |
| $args->{print_me} .= "\n" if $i; |
| |
| ### allowable answers are now equal to the choices listed |
| $args->{allow} = $args->{choices}; |
| |
| ### no choices, but a default? set 'prompt_add' to the default |
| ### to construct a 'foo? [DEFAULT]' type prompt |
| } elsif ( defined $args->{default} ) { |
| $prompt_add = $args->{default}; |
| } |
| |
| ### we set up the defaults, prompts etc, dispatch to the readline call |
| return $term->_tt_readline( %$args, prompt_add => $prompt_add ); |
| |
| } |
| |
| =head2 $bool = $term->ask_yn( prompt => "your question", [default => (y|1,n|0), print_me => "extra text to print & record"] ) |
| |
| Asks a simple C<yes> or C<no> question to the user, returning a boolean |
| indicating C<true> or C<false> to the caller. |
| |
| The C<default> answer will automatically returned, if the user hits |
| C<enter> or if C<$AUTOREPLY> is set to true. See the C<GLOBAL VARIABLES> |
| section further below. |
| |
| Also, you have the option of adding a C<print_me> argument, which is |
| simply printed before the prompt. It's printed to the same file handle |
| as the rest of the questions, so you can use this to keep track of a |
| full session of Q&A with the user, and retrieve it later using the |
| C<< Term::UI->history_as_string >> function. |
| |
| |
| See the C<EXAMPLES> section for samples of how to use this function. |
| |
| =cut |
| |
| sub ask_yn { |
| my $term = shift; |
| my %hash = @_; |
| |
| my $tmpl = { |
| default => { default => undef, allow => [qw|0 1 y n|], |
| strict_type => 1 }, |
| prompt => { default => '', required => 1, strict_type => 1 }, |
| print_me => { default => '', strict_type => 1 }, |
| multi => { default => 0, no_override => 1 }, |
| choices => { default => [qw|y n|], no_override => 1 }, |
| allow => { default => [qr/^y(?:es)?$/i, qr/^n(?:o)?$/i], |
| no_override => 1 |
| }, |
| }; |
| |
| my $args = check( $tmpl, \%hash, $VERBOSE ) or return undef; |
| |
| ### uppercase the default choice, if there is one, to be added |
| ### to the prompt in a 'foo? [Y/n]' type style. |
| my $prompt_add; |
| { my @list = @{$args->{choices}}; |
| if( defined $args->{default} ) { |
| |
| ### if you supplied the default as a boolean, rather than y/n |
| ### transform it to a y/n now |
| $args->{default} = $args->{default} =~ /\d/ |
| ? { 0 => 'n', 1 => 'y' }->{ $args->{default} } |
| : $args->{default}; |
| |
| @list = map { lc $args->{default} eq lc $_ |
| ? uc $args->{default} |
| : $_ |
| } @list; |
| } |
| |
| $prompt_add .= join("/", @list); |
| } |
| |
| my $rv = $term->_tt_readline( %$args, prompt_add => $prompt_add ); |
| |
| return $rv =~ /^y/i ? 1 : 0; |
| } |
| |
| |
| |
| sub _tt_readline { |
| my $term = shift; |
| my %hash = @_; |
| |
| local $Params::Check::VERBOSE = 0; # why is this? |
| local $| = 1; # print ASAP |
| |
| |
| my ($default, $prompt, $choices, $multi, $allow, $prompt_add, $print_me); |
| my $tmpl = { |
| default => { default => undef, strict_type => 1, |
| store => \$default }, |
| prompt => { default => '', strict_type => 1, required => 1, |
| store => \$prompt }, |
| choices => { default => [], strict_type => 1, |
| store => \$choices }, |
| multi => { default => 0, allow => [0, 1], store => \$multi }, |
| allow => { default => qr/.*/, store => \$allow, }, |
| prompt_add => { default => '', store => \$prompt_add }, |
| print_me => { default => '', store => \$print_me }, |
| }; |
| |
| check( $tmpl, \%hash, $VERBOSE ) or return; |
| |
| ### prompts for Term::ReadLine can't be longer than one line, or |
| ### it can display wonky on some terminals. |
| history( $print_me ) if $print_me; |
| |
| |
| ### we might have to add a default value to the prompt, to |
| ### show the user what will be picked by default: |
| $prompt .= " [$prompt_add]: " if $prompt_add; |
| |
| |
| ### are we in autoreply mode? |
| if ($AUTOREPLY) { |
| |
| ### you used autoreply, but didnt provide a default! |
| carp loc( |
| q[You have '%1' set to true, but did not provide a default!], |
| '$AUTOREPLY' |
| ) if( !defined $default && $VERBOSE); |
| |
| ### print it out for visual feedback |
| history( join ' ', grep { defined } $prompt, $default ); |
| |
| ### and return the default |
| return $default; |
| } |
| |
| |
| ### so, no AUTOREPLY, let's see what the user will answer |
| LOOP: { |
| |
| ### annoying bug in T::R::Perl that mucks up lines with a \n |
| ### in them; So split by \n, save the last line as the prompt |
| ### and just print the rest |
| { my @lines = split "\n", $prompt; |
| $prompt = pop @lines; |
| |
| history( "$_\n" ) for @lines; |
| } |
| |
| ### pose the question |
| my $answer = $term->readline($prompt); |
| $answer = $default unless length $answer; |
| |
| $term->addhistory( $answer ) if length $answer; |
| |
| ### add both prompt and answer to the history |
| history( "$prompt $answer", 0 ); |
| |
| ### if we're allowed to give multiple answers, split |
| ### the answer on whitespace |
| my @answers = $multi ? split(/\s+/, $answer) : $answer; |
| |
| ### the return value list |
| my @rv; |
| |
| if( @$choices ) { |
| |
| for my $answer (@answers) { |
| |
| ### a digit implies a multiple choice question, |
| ### a non-digit is an open answer |
| if( $answer =~ /\D/ ) { |
| push @rv, $answer if allow( $answer, $allow ); |
| } else { |
| |
| ### remember, the answer digits are +1 compared to |
| ### the choices, because humans want to start counting |
| ### at 1, not at 0 |
| push @rv, $choices->[ $answer - 1 ] |
| if $answer > 0 && defined $choices->[ $answer - 1]; |
| } |
| } |
| |
| ### no fixed list of choices.. just check if the answers |
| ### (or otherwise the default!) pass the allow handler |
| } else { |
| push @rv, grep { allow( $_, $allow ) } |
| scalar @answers ? @answers : ($default); |
| } |
| |
| ### if not all the answers made it to the return value list, |
| ### at least one of them was an invalid answer -- make the |
| ### user do it again |
| if( (@rv != @answers) or |
| (scalar(@$choices) and not scalar(@answers)) |
| ) { |
| $prompt = $INVALID; |
| $prompt .= "[$prompt_add] " if $prompt_add; |
| redo LOOP; |
| |
| ### otherwise just return the answer, or answers, depending |
| ### on the multi setting |
| } else { |
| return $multi ? @rv : $rv[0]; |
| } |
| } |
| } |
| |
| =head2 ($opts, $munged) = $term->parse_options( STRING ); |
| |
| C<parse_options> will convert all options given from an input string |
| to a hash reference. If called in list context it will also return |
| the part of the input string that it found no options in. |
| |
| Consider this example: |
| |
| my $str = q[command --no-foo --baz --bar=0 --quux=bleh ] . |
| q[--option="some'thing" -one-dash -single=blah' arg]; |
| |
| my ($options,$munged) = $term->parse_options($str); |
| |
| ### $options would contain: ### |
| $options = { |
| 'foo' => 0, |
| 'bar' => 0, |
| 'one-dash' => 1, |
| 'baz' => 1, |
| 'quux' => 'bleh', |
| 'single' => 'blah\'', |
| 'option' => 'some\'thing' |
| }; |
| |
| ### and this is the munged version of the input string, |
| ### ie what's left of the input minus the options |
| $munged = 'command arg'; |
| |
| As you can see, you can either use a single or a double C<-> to |
| indicate an option. |
| If you prefix an option with C<no-> and do not give it a value, it |
| will be set to 0. |
| If it has no prefix and no value, it will be set to 1. |
| Otherwise, it will be set to its value. Note also that it can deal |
| fine with single/double quoting issues. |
| |
| =cut |
| |
| sub parse_options { |
| my $term = shift; |
| my $input = shift; |
| |
| my $return = {}; |
| |
| ### there's probably a more elegant way to do this... ### |
| while ( $input =~ s/(?:^|\s+)--?([-\w]+=("|').+?\2)(?=\Z|\s+)// or |
| $input =~ s/(?:^|\s+)--?([-\w]+=\S+)(?=\Z|\s+)// or |
| $input =~ s/(?:^|\s+)--?([-\w]+)(?=\Z|\s+)// |
| ) { |
| my $match = $1; |
| |
| if( $match =~ /^([-\w]+)=("|')(.+?)\2$/ ) { |
| $return->{$1} = $3; |
| |
| } elsif( $match =~ /^([-\w]+)=(\S+)$/ ) { |
| $return->{$1} = $2; |
| |
| } elsif( $match =~ /^no-?([-\w]+)$/i ) { |
| $return->{$1} = 0; |
| |
| } elsif ( $match =~ /^([-\w]+)$/ ) { |
| $return->{$1} = 1; |
| |
| } else { |
| carp(loc(q[I do not understand option "%1"\n], $match)) if $VERBOSE; |
| } |
| } |
| |
| return wantarray ? ($return,$input) : $return; |
| } |
| |
| =head2 $str = $term->history_as_string |
| |
| Convenience wrapper around C<< Term::UI::History->history_as_string >>. |
| |
| Consult the C<Term::UI::History> man page for details. |
| |
| =cut |
| |
| sub history_as_string { return Term::UI::History->history_as_string }; |
| |
| 1; |
| |
| =head1 GLOBAL VARIABLES |
| |
| The behaviour of Term::UI can be altered by changing the following |
| global variables: |
| |
| =head2 $Term::UI::VERBOSE |
| |
| This controls whether Term::UI will issue warnings and explanations |
| as to why certain things may have failed. If you set it to 0, |
| Term::UI will not output any warnings. |
| The default is 1; |
| |
| =head2 $Term::UI::AUTOREPLY |
| |
| This will make every question be answered by the default, and warn if |
| there was no default provided. This is particularly useful if your |
| program is run in non-interactive mode. |
| The default is 0; |
| |
| =head2 $Term::UI::INVALID |
| |
| This holds the string that will be printed when the user makes an |
| invalid choice. |
| You can override this string from your program if you, for example, |
| wish to do localization. |
| The default is C<Invalid selection, please try again: > |
| |
| =head2 $Term::UI::History::HISTORY_FH |
| |
| This is the filehandle all the print statements from this module |
| are being sent to. Please consult the C<Term::UI::History> manpage |
| for details. |
| |
| This defaults to C<*STDOUT>. |
| |
| =head1 EXAMPLES |
| |
| =head2 Basic get_reply sample |
| |
| ### ask a user (with an open question) for their favourite colour |
| $reply = $term->get_reply( prompt => 'Your favourite colour? ); |
| |
| which would look like: |
| |
| Your favourite colour? |
| |
| and C<$reply> would hold the text the user typed. |
| |
| =head2 get_reply with choices |
| |
| ### now provide a list of choices, so the user has to pick one |
| $reply = $term->get_reply( |
| prompt => 'Your favourite colour?', |
| choices => [qw|red green blue|] ); |
| |
| which would look like: |
| |
| 1> red |
| 2> green |
| 3> blue |
| |
| Your favourite colour? |
| |
| C<$reply> will hold one of the choices presented. C<Term::UI> will repose |
| the question if the user attempts to enter an answer that's not in the |
| list of choices. The string presented is held in the C<$Term::UI::INVALID> |
| variable (see the C<GLOBAL VARIABLES> section for details. |
| |
| =head2 get_reply with choices and default |
| |
| ### provide a sensible default option -- everyone loves blue! |
| $reply = $term->get_reply( |
| prompt => 'Your favourite colour?', |
| choices => [qw|red green blue|], |
| default => 'blue' ); |
| |
| which would look like: |
| |
| 1> red |
| 2> green |
| 3> blue |
| |
| Your favourite colour? [3]: |
| |
| Note the default answer after the prompt. A user can now just hit C<enter> |
| (or set C<$Term::UI::AUTOREPLY> -- see the C<GLOBAL VARIABLES> section) and |
| the sensible answer 'blue' will be returned. |
| |
| =head2 get_reply using print_me & multi |
| |
| ### allow the user to pick more than one colour and add an |
| ### introduction text |
| @reply = $term->get_reply( |
| print_me => 'Tell us what colours you like', |
| prompt => 'Your favourite colours?', |
| choices => [qw|red green blue|], |
| multi => 1 ); |
| |
| which would look like: |
| |
| Tell us what colours you like |
| 1> red |
| 2> green |
| 3> blue |
| |
| Your favourite colours? |
| |
| An answer of C<3 2 1> would fill C<@reply> with C<blue green red> |
| |
| =head2 get_reply & allow |
| |
| ### pose an open question, but do a custom verification on |
| ### the answer, which will only exit the question loop, if |
| ### the answer matches the allow handler. |
| $reply = $term->get_reply( |
| prompt => "What is the magic number?", |
| allow => 42 ); |
| |
| Unless the user now enters C<42>, the question will be reposed over |
| and over again. You can use more sophisticated C<allow> handlers (even |
| subroutines can be used). The C<allow> handler is implemented using |
| C<Params::Check>'s C<allow> function. Check its manpage for details. |
| |
| =head2 an elaborate ask_yn sample |
| |
| ### ask a user if he likes cookies. Default to a sensible 'yes' |
| ### and inform him first what cookies are. |
| $bool = $term->ask_yn( prompt => 'Do you like cookies?', |
| default => 'y', |
| print_me => 'Cookies are LOVELY!!!' ); |
| |
| would print: |
| |
| Cookies are LOVELY!!! |
| Do you like cookies? [Y/n]: |
| |
| If a user then simply hits C<enter>, agreeing with the default, |
| C<$bool> would be set to C<true>. (Simply hitting 'y' would also |
| return C<true>. Hitting 'n' would return C<false>) |
| |
| We could later retrieve this interaction by printing out the Q&A |
| history as follows: |
| |
| print $term->history_as_string; |
| |
| which would then print: |
| |
| Cookies are LOVELY!!! |
| Do you like cookies? [Y/n]: y |
| |
| There's a chance we're doing this non-interactively, because a console |
| is missing, the user indicated he just wanted the defaults, etc. |
| |
| In this case, simply setting C<$Term::UI::AUTOREPLY> to true, will |
| return from every question with the default answer set for the question. |
| Do note that if C<AUTOREPLY> is true, and no default is set, C<Term::UI> |
| will warn about this and return C<undef>. |
| |
| =head1 See Also |
| |
| C<Params::Check>, C<Term::ReadLine>, C<Term::UI::History> |
| |
| =head1 BUG REPORTS |
| |
| Please report bugs or other issues to E<lt>bug-term-ui@rt.cpan.org<gt>. |
| |
| =head1 AUTHOR |
| |
| This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. |
| |
| =head1 COPYRIGHT |
| |
| This library is free software; you may redistribute and/or modify it |
| under the same terms as Perl itself. |
| |
| =cut |