From 4f08f5ada97fa0f9dfbff054b8e0cb6ecd25c326 Mon Sep 17 00:00:00 2001 From: Jos Boumans Date: Mon, 23 Oct 2006 14:07:23 +0200 Subject: [PATCH] Add Term::UI to the core From: "Jos Boumans" Message-ID: <19689.80.127.35.68.1161598043.squirrel@webmail.xs4all.nl> p4raw-id: //depot/perl@29112 --- MANIFEST | 5 + lib/Term/UI.pm | 620 +++++++++++++++++++++++++++++++++++++++++++++ lib/Term/UI/History.pm | 137 ++++++++++ lib/Term/UI/t/00_load.t | 14 + lib/Term/UI/t/01_history.t | 71 ++++++ lib/Term/UI/t/02_ui.t | 126 +++++++++ 6 files changed, 973 insertions(+) create mode 100644 lib/Term/UI.pm create mode 100644 lib/Term/UI/History.pm create mode 100644 lib/Term/UI/t/00_load.t create mode 100644 lib/Term/UI/t/01_history.t create mode 100644 lib/Term/UI/t/02_ui.t diff --git a/MANIFEST b/MANIFEST index 83f15f2..9706ec7 100644 --- a/MANIFEST +++ b/MANIFEST @@ -2373,6 +2373,11 @@ lib/Term/Complete.pm A command completion subroutine lib/Term/Complete.t See if Term::Complete works lib/Term/ReadLine.pm Stub readline library lib/Term/ReadLine.t See if Term::ReadLine works +lib/Term/UI/History.pm Term::UI +lib/Term/UI.pm Term::UI +lib/Term/UI/t/00_load.t Term::UI tests +lib/Term/UI/t/01_history.t Term::UI tests +lib/Term/UI/t/02_ui.t Term::UI tests lib/Test/Builder/Module.pm Base class for test modules lib/Test/Builder.pm For writing new test libraries lib/Test/Builder/Tester/Color.pm Turn on color in Test::Builder::Tester diff --git a/lib/Term/UI.pm b/lib/Term/UI.pm new file mode 100644 index 0000000..a7d136b --- /dev/null +++ b/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.14'; + $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 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 will DWYM. + +For asking a yes or no question, there's even a shortcut. + +=head1 HOW IT WORKS + +C places itself at the back of the C +C<@ISA> array, so you can call its functions through your term object. + +C uses C to record all interactions +with the commandline. You can retrieve this history, or alter +the filehandle the interaction is printed to. See the +C manpage or the C 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 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 argument. If the answer is not in the list of choices +presented, the question will be reposed. + +If you provide a C answer, this will be returned when either +C<$AUTOREPLY> is set to true, (see the C section further +below), or when the user just hits C. + +You can indicate that the user is allowed to enter multiple answers by +toggling the C flag. Note that a list of answers will then be +returned to you, rather than a simple string. + +By specifying an C hander, you can yourself validate the answer +a user gives. This can be any of the types that the Params::Check C +function allows, so please refer to that manpage for details. + +Finally, you have the option of adding a C 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 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 $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 or C question to the user, returning a boolean +indicating C or C to the caller. + +The C answer will automatically returned, if the user hits +C or if C<$AUTOREPLY> is set to true. See the C +section further below. + +Also, you have the option of adding a C 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 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 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 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/--?([-\w]+=("|').+?\2)(?:\Z|\s+)// or + $input =~ s/--?([-\w]+=\S+)(?:\Z|\s+)// or + $input =~ 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 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 + +=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 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 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 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 +(or set C<$Term::UI::AUTOREPLY> -- see the C 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 + +=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 handlers (even +subroutines can be used). The C handler is implemented using +C's C 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, agreeing with the default, +C<$bool> would be set to C. (Simply hitting 'y' would also +return C. Hitting 'n' would return C) + +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 is true, and no default is set, C +will warn about this and return C. + +=head1 See Also + +C, C, C + +=head1 AUTHOR + +This module by +Jos Boumans Ekane@cpan.orgE. + +=head1 COPYRIGHT + +This module is +copyright (c) 2002 - 2005 Jos Boumans Ekane@cpan.orgE. +All rights reserved. + +This library is free software; +you may redistribute and/or modify it under the same +terms as Perl itself. diff --git a/lib/Term/UI/History.pm b/lib/Term/UI/History.pm new file mode 100644 index 0000000..9ac09aa --- /dev/null +++ b/lib/Term/UI/History.pm @@ -0,0 +1,137 @@ +package Term::UI::History; + +use strict; +use base 'Exporter'; +use base 'Log::Message::Simple'; + +=pod + +=head1 NAME + +Log::Message::Simple + +=head1 SYNOPSIS + + use Term::UI::History qw[history]; + + history("Some message"); + + ### retrieve the history in printable form + $hist = Term::UI::History->history_as_string; + + ### redirect output + local $Term::UI::History::HISTORY_FH = \*STDERR; + +=head1 DESCRIPTION + +This module provides the C function for C, +printing and saving all the C interaction. + +Refer to the C manpage for details on usage from +C. + +This module subclasses C. Refer to its +manpage for additional functionality available via this package. + +=head1 FUNCTIONS + +=head2 history("message string" [,VERBOSE]) + +Records a message on the stack, and prints it to C +(or actually C<$HISTORY_FH>, see the C section +below), if the C option is true. + +The C option defaults to true. + +=cut + +BEGIN { + use Log::Message private => 0; + + use vars qw[ @EXPORT $HISTORY_FH ]; + @EXPORT = qw[ history ]; + my $log = new Log::Message; + $HISTORY_FH = \*STDOUT; + + for my $func ( @EXPORT ) { + no strict 'refs'; + + *$func = sub { my $msg = shift; + $log->store( + message => $msg, + tag => uc $func, + level => $func, + extra => [@_] + ); + }; + } + + sub history_as_string { + my $class = shift; + + return join $/, map { $_->message } __PACKAGE__->stack; + } +} + + +{ package Log::Message::Handlers; + + sub history { + my $self = shift; + my $verbose = shift; + $verbose = 1 unless defined $verbose; # default to true + + ### so you don't want us to print the msg? ### + return if defined $verbose && $verbose == 0; + + local $| = 1; + my $old_fh = select $Term::UI::History::HISTORY_FH; + + print $self->message . "\n"; + select $old_fh; + + return; + } +} + + +=head1 GLOBAL VARIABLES + +=over 4 + +=item $HISTORY_FH + +This is the filehandle all the messages sent to C are being +printed. This defaults to C<*STDOUT>. + +=back + +=head1 See Also + +C, C + +=head1 AUTHOR + +This module by +Jos Boumans Ekane@cpan.orgE. + +=head1 COPYRIGHT + +This module is +copyright (c) 2005 Jos Boumans Ekane@cpan.orgE. +All rights reserved. + +This library is free software; +you may redistribute and/or modify it under the same +terms as Perl itself. + +=cut + +1; + +# Local variables: +# c-indentation-style: bsd +# c-basic-offset: 4 +# indent-tabs-mode: nil +# End: +# vim: expandtab shiftwidth=4: diff --git a/lib/Term/UI/t/00_load.t b/lib/Term/UI/t/00_load.t new file mode 100644 index 0000000..aacd60f --- /dev/null +++ b/lib/Term/UI/t/00_load.t @@ -0,0 +1,14 @@ +use Test::More 'no_plan'; +use strict; + +BEGIN { + chdir 't' if -d 't'; + use File::Spec; + use lib File::Spec->catdir( qw[.. lib] ); +} + +my $Class = 'Term::UI'; + +use_ok( $Class ); + +diag "Testing $Class " . $Class->VERSION unless $ENV{PERL_CORE}; diff --git a/lib/Term/UI/t/01_history.t b/lib/Term/UI/t/01_history.t new file mode 100644 index 0000000..b0219de --- /dev/null +++ b/lib/Term/UI/t/01_history.t @@ -0,0 +1,71 @@ +use Test::More 'no_plan'; +use strict; + +BEGIN { + chdir 't' if -d 't'; + use File::Spec; + use lib File::Spec->catdir( qw[.. lib] ); +} + +my $Class = 'Term::UI::History'; +my $Func = 'history'; +my $Verbose = 0; # print to STDOUT? + +### test load & exports +{ use_ok( $Class ); + + for my $pkg ( $Class, __PACKAGE__ ) { + can_ok( $pkg, $Func ); + } +} + +### test string recording +{ history( $$, $Verbose ); + + my $str = $Class->history_as_string; + + ok( $str, "Message recorded" ); + is( $str, $$, " With appropriate content" ); + + $Class->flush; + ok( !$Class->history_as_string, + " Stack flushed" ); +} + +### test filehandle printing +SKIP: { + my $file = "$$.tmp"; + + { open my $fh, ">$file" or skip "Could not open $file: $!", 6; + + ### declare twice for 'used only once' warning + local $Term::UI::History::HISTORY_FH = $fh; + local $Term::UI::History::HISTORY_FH = $fh; + + history( $$ ); + + close $fh; + } + + my $str = $Class->history_as_string; + ok( $str, "Message recorded" ); + is( $str, $$, " With appropriate content" ); + + ### check file contents + { ok( -e $file, "File $file exists" ); + ok( -s $file, " File has size" ); + + open my $fh, $file or skip "Could not open $file: $!", 2; + my $cont = do { local $/; <$fh> }; + chomp $cont; + + is( $cont, $str, " File has same content" ); + } + + $Class->flush; + + ### for VMS etc + 1 while unlink $file; + + ok( ! -e $file, " File $file removed" ); +} diff --git a/lib/Term/UI/t/02_ui.t b/lib/Term/UI/t/02_ui.t new file mode 100644 index 0000000..18a60a4 --- /dev/null +++ b/lib/Term/UI/t/02_ui.t @@ -0,0 +1,126 @@ +### Term::UI test suite ### + +use strict; +use lib qw[../lib lib]; +use Test::More tests => 13; +use Term::ReadLine; + +use_ok( 'Term::UI' ); + +### make sure we can do this automatically ### +$Term::UI::AUTOREPLY = $Term::UI::AUTOREPLY = 1; +$Term::UI::VERBOSE = $Term::UI::VERBOSE = 0; + +### enable warnings +$^W = 1; + +### perl core gets upset if we print stuff to STDOUT... +if( $ENV{PERL_CORE} ) { + *STDOUT_SAVE = *STDOUT_SAVE = *STDOUT; + close *STDOUT; + open *STDOUT, ">termui.$$" or diag("Could not open tempfile"); +} +END { unlink "termui.$$" if $ENV{PERL_CORE} } + + +### so T::RL doesn't go nuts over no console +BEGIN{ $ENV{LINES}=25; $ENV{COLUMNS}=80; } +my $term = Term::ReadLine->new('test') + or diag "Could not create a new term. Dying", die; + +my $tmpl = { + prompt => "What is your favourite colour?", + choices => [qw|blue red green|], + default => 'blue', + }; + +{ + my $args = \%{ $tmpl }; + + is( $term->get_reply( %$args ), 'blue', q[Checking reply with defaults and choices] ); +} + +{ + my $args = \%{ $tmpl }; + delete $args->{choices}; + + is( $term->get_reply( %$args ), 'blue', q[Checking reply with defaults] ); +} + +{ + my $args = { + prompt => 'Do you like cookies?', + default => 'y', + }; + + is( $term->ask_yn( %$args ), 1, q[Asking yes/no with 'yes' as default] ); +} + +{ + my $args = { + prompt => 'Do you like Python?', + default => 'n', + }; + + is( $term->ask_yn( %$args ), 0, q[Asking yes/no with 'no' as default] ); +} + + +# used to print: Use of uninitialized value in length at Term/UI.pm line 141. +# [#13412] +{ my $args = { + prompt => 'Uninit warning on empty default', + }; + + my $warnings = ''; + local $SIG{__WARN__} = sub { $warnings .= "@_" }; + + my $res = $term->get_reply( %$args ); + + ok( !$res, "Empty result on autoreply without default" ); + is( $warnings, '', " No warnings with empty default" ); + unlike( $warnings, qr|Term.UI|, + " No warnings from Term::UI" ); + +} + +# used to print: Use of uninitialized value in string at Params/Check.pm +# [#13412] +{ my $args = { + prompt => 'Undef warning on failing allow', + allow => sub { 0 }, + }; + + my $warnings = ''; + local $SIG{__WARN__} = sub { $warnings .= "@_" }; + + my $res = $term->get_reply( %$args ); + + ok( !$res, "Empty result on autoreply without default" ); + is( $warnings, '', " No warnings with failing allow" ); + unlike( $warnings, qr|Params.Check|, + " No warnings from Params::Check" ); + +} + +#### test parse_options +{ + my $str = q[command --no-foo --baz --bar=0 --quux=bleh ] . + q[--option="some'thing" -one-dash -single=blah' foo]; + + my $munged = 'command foo'; + my $expected = { + foo => 0, + baz => 1, + bar => 0, + quux => 'bleh', + option => q[some'thing], + 'one-dash' => 1, + single => q[blah'], + }; + + my ($href,$rest) = $term->parse_options( $str ); + + is_deeply( $href, $expected, q[Parsing options] ); + is($rest,$munged, q[Remaining unparsed string] ); +} -- 2.7.4