diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Term/UI.pm')
| -rw-r--r-- | Master/tlpkg/tlperl/lib/Term/UI.pm | 620 |
1 files changed, 620 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Term/UI.pm b/Master/tlpkg/tlperl/lib/Term/UI.pm new file mode 100644 index 00000000000..136f75bb6ad --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Term/UI.pm @@ -0,0 +1,620 @@ +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.20'; + $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 seperately 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 |