cpan/Term-UI/lib/Term/UI.pm

   1 package Term::UI;
   2
   3 use Carp;
   4 use Params::Check qw[check allow];
   5 use Term::ReadLine;
   6 use Locale::Maketext::Simple Style => 'gettext';
   7 use Term::UI::History;
   8
   9 use strict;
  10
  11 BEGIN {
  12     use vars        qw[$VERSION $AUTOREPLY $VERBOSE $INVALID];
  13     $VERBOSE    =   1;
  14     $VERSION    =   '0.24';
  15     $INVALID    =   loc('Invalid selection, please try again: ');
  16 }
  17
  18 push @Term::ReadLine::Stub::ISA, __PACKAGE__
  19         unless grep { $_ eq __PACKAGE__ } @Term::ReadLine::Stub::ISA;
  20
  21
  22 =pod
  23
  24 =head1 NAME
  25
  26 Term::UI - Term::ReadLine UI made easy
  27
  28 =head1 SYNOPSIS
  29
  30     use Term::UI;
  31     use Term::ReadLine;
  32
  33     my $term = Term::ReadLine->new('brand');
  34
  35     my $reply = $term->get_reply(
  36                     prompt => 'What is your favourite colour?',
  37                     choices => [qw|blue red green|],
  38                     default => blue,
  39     );
  40
  41     my $bool = $term->ask_yn(
  42                         prompt => 'Do you like cookies?',
  43                         default => 'y',
  44                 );
  45
  46
  47     my $string = q[some_command -option --no-foo --quux='this thing'];
  48
  49     my ($options,$munged_input) = $term->parse_options($string);
  50
  51
  52     ### don't have Term::UI issue warnings -- default is '1'
  53     $Term::UI::VERBOSE = 0;
  54
  55     ### always pick the default (good for non-interactive terms)
  56     ### -- default is '0'
  57     $Term::UI::AUTOREPLY = 1;
  58
  59     ### Retrieve the entire session as a printable string:
  60     $hist = Term::UI::History->history_as_string;
  61     $hist = $term->history_as_string;
  62
  63 =head1 DESCRIPTION
  64
  65 C<Term::UI> is a transparent way of eliminating the overhead of having
  66 to format a question and then validate the reply, informing the user
  67 if the answer was not proper and re-issuing the question.
  68
  69 Simply give it the question you want to ask, optionally with choices
  70 the user can pick from and a default and C<Term::UI> will DWYM.
  71
  72 For asking a yes or no question, there's even a shortcut.
  73
  74 =head1 HOW IT WORKS
  75
  76 C<Term::UI> places itself at the back of the C<Term::ReadLine>
  77 C<@ISA> array, so you can call its functions through your term object.
  78
  79 C<Term::UI> uses C<Term::UI::History> to record all interactions
  80 with the commandline. You can retrieve this history, or alter
  81 the filehandle the interaction is printed to. See the
  82 C<Term::UI::History> manpage or the C<SYNOPSIS> for details.
  83
  84 =head1 METHODS
  85
  86 =head2 $reply = $term->get_reply( prompt => 'question?', [choices => \@list, default => $list[0], multi => BOOL, print_me => "extra text to print & record", allow => $ref] );
  87
  88 C<get_reply> asks a user a question, and then returns the reply to the
  89 caller. If the answer is invalid (more on that below), the question will
  90 be reposed, until a satisfactory answer has been entered.
  91
  92 You have the option of providing a list of choices the user can pick from
  93 using the C<choices> argument. If the answer is not in the list of choices
  94 presented, the question will be reposed.
  95
  96 If you provide a C<default>  answer, this will be returned when either
  97 C<$AUTOREPLY> is set to true, (see the C<GLOBAL VARIABLES> section further
  98 below), or when the user just hits C<enter>.
  99
 100 You can indicate that the user is allowed to enter multiple answers by
 101 toggling the C<multi> flag. Note that a list of answers will then be
 102 returned to you, rather than a simple string.
 103
 104 By specifying an C<allow> hander, you can yourself validate the answer
 105 a user gives. This can be any of the types that the Params::Check C<allow>
 106 function allows, so please refer to that manpage for details.
 107
 108 Finally, you have the option of adding a C<print_me> argument, which is
 109 simply printed before the prompt. It's printed to the same file handle
 110 as the rest of the questions, so you can use this to keep track of a
 111 full session of Q&A with the user, and retrieve it later using the
 112 C<< Term::UI->history_as_string >> function.
 113
 114 See the C<EXAMPLES> section for samples of how to use this function.
 115
 116 =cut
 117
 118 sub get_reply {
 119     my $term = shift;
 120     my %hash = @_;
 121
 122     my $tmpl = {
 123         default     => { default => undef,  strict_type => 1 },
 124         prompt      => { default => '',     strict_type => 1, required => 1 },
 125         choices     => { default => [],     strict_type => 1 },
 126         multi       => { default => 0,      allow => [0, 1] },
 127         allow       => { default => qr/.*/ },
 128         print_me    => { default => '',     strict_type => 1 },
 129     };
 130
 131     my $args = check( $tmpl, \%hash, $VERBOSE )
 132                 or ( carp( loc(q[Could not parse arguments]) ), return );
 133
 134
 135     ### add this to the prompt to indicate the default
 136     ### answer to the question if there is one.
 137     my $prompt_add;
 138
 139     ### if you supplied several choices to pick from,
 140     ### we'll print them separately before the prompt
 141     if( @{$args->{choices}} ) {
 142         my $i;
 143
 144         for my $choice ( @{$args->{choices}} ) {
 145             $i++;   # the answer counter -- but humans start counting
 146                     # at 1 :D
 147
 148             ### so this choice is the default? add it to 'prompt_add'
 149             ### so we can construct a "foo? [DIGIT]" type prompt
 150             $prompt_add = $i if (defined $args->{default} and $choice eq $args->{default});
 151
 152             ### create a "DIGIT> choice" type line
 153             $args->{print_me} .= sprintf "\n%3s> %-s", $i, $choice;
 154         }
 155
 156         ### we listed some choices -- add another newline for
 157         ### pretty printing
 158         $args->{print_me} .= "\n" if $i;
 159
 160         ### allowable answers are now equal to the choices listed
 161         $args->{allow} = $args->{choices};
 162
 163     ### no choices, but a default? set 'prompt_add' to the default
 164     ### to construct a 'foo? [DEFAULT]' type prompt
 165     } elsif ( defined $args->{default} ) {
 166         $prompt_add = $args->{default};
 167     }
 168
 169     ### we set up the defaults, prompts etc, dispatch to the readline call
 170     return $term->_tt_readline( %$args, prompt_add => $prompt_add );
 171
 172 }
 173
 174 =head2 $bool = $term->ask_yn( prompt => "your question", [default => (y|1,n|0), print_me => "extra text to print & record"] )
 175
 176 Asks a simple C<yes> or C<no> question to the user, returning a boolean
 177 indicating C<true> or C<false> to the caller.
 178
 179 The C<default> answer will automatically returned, if the user hits
 180 C<enter> or if C<$AUTOREPLY> is set to true. See the C<GLOBAL VARIABLES>
 181 section further below.
 182
 183 Also, you have the option of adding a C<print_me> argument, which is
 184 simply printed before the prompt. It's printed to the same file handle
 185 as the rest of the questions, so you can use this to keep track of a
 186 full session of Q&A with the user, and retrieve it later using the
 187 C<< Term::UI->history_as_string >> function.
 188
 189
 190 See the C<EXAMPLES> section for samples of how to use this function.
 191
 192 =cut
 193
 194 sub ask_yn {
 195     my $term = shift;
 196     my %hash = @_;
 197
 198     my $tmpl = {
 199         default     => { default => undef, allow => [qw|0 1 y n|],
 200                                                             strict_type => 1 },
 201         prompt      => { default => '', required => 1,      strict_type => 1 },
 202         print_me    => { default => '',                     strict_type => 1 },
 203         multi       => { default => 0,                      no_override => 1 },
 204         choices     => { default => [qw|y n|],              no_override => 1 },
 205         allow       => { default => [qr/^y(?:es)?$/i, qr/^n(?:o)?$/i],
 206                          no_override => 1
 207                        },
 208     };
 209
 210     my $args = check( $tmpl, \%hash, $VERBOSE ) or return undef;
 211
 212     ### uppercase the default choice, if there is one, to be added
 213     ### to the prompt in a 'foo? [Y/n]' type style.
 214     my $prompt_add;
 215     {   my @list = @{$args->{choices}};
 216         if( defined $args->{default} ) {
 217
 218             ### if you supplied the default as a boolean, rather than y/n
 219             ### transform it to a y/n now
 220             $args->{default} = $args->{default} =~ /\d/
 221                                 ? { 0 => 'n', 1 => 'y' }->{ $args->{default} }
 222                                 : $args->{default};
 223
 224             @list = map { lc $args->{default} eq lc $_
 225                                 ? uc $args->{default}
 226                                 : $_
 227                     } @list;
 228         }
 229
 230         $prompt_add .= join("/", @list);
 231     }
 232
 233     my $rv = $term->_tt_readline( %$args, prompt_add => $prompt_add );
 234
 235     return $rv =~ /^y/i ? 1 : 0;
 236 }
 237
 238
 239
 240 sub _tt_readline {
 241     my $term = shift;
 242     my %hash = @_;
 243
 244     local $Params::Check::VERBOSE = 0;  # why is this?
 245     local $| = 1;                       # print ASAP
 246
 247
 248     my ($default, $prompt, $choices, $multi, $allow, $prompt_add, $print_me);
 249     my $tmpl = {
 250         default     => { default => undef,  strict_type => 1,
 251                             store => \$default },
 252         prompt      => { default => '',     strict_type => 1, required => 1,
 253                             store => \$prompt },
 254         choices     => { default => [],     strict_type => 1,
 255                             store => \$choices },
 256         multi       => { default => 0,      allow => [0, 1], store => \$multi },
 257         allow       => { default => qr/.*/, store => \$allow, },
 258         prompt_add  => { default => '',     store => \$prompt_add },
 259         print_me    => { default => '',     store => \$print_me },
 260     };
 261
 262     check( $tmpl, \%hash, $VERBOSE ) or return;
 263
 264     ### prompts for Term::ReadLine can't be longer than one line, or
 265     ### it can display wonky on some terminals.
 266     history( $print_me ) if $print_me;
 267
 268
 269     ### we might have to add a default value to the prompt, to
 270     ### show the user what will be picked by default:
 271     $prompt .= " [$prompt_add]: " if $prompt_add;
 272
 273
 274     ### are we in autoreply mode?
 275     if ($AUTOREPLY) {
 276
 277         ### you used autoreply, but didnt provide a default!
 278         carp loc(
 279             q[You have '%1' set to true, but did not provide a default!],
 280             '$AUTOREPLY'
 281         ) if( !defined $default && $VERBOSE);
 282
 283         ### print it out for visual feedback
 284         history( join ' ', grep { defined } $prompt, $default );
 285
 286         ### and return the default
 287         return $default;
 288     }
 289
 290
 291     ### so, no AUTOREPLY, let's see what the user will answer
 292     LOOP: {
 293
 294         ### annoying bug in T::R::Perl that mucks up lines with a \n
 295         ### in them; So split by \n, save the last line as the prompt
 296         ### and just print the rest
 297         {   my @lines   = split "\n", $prompt;
 298             $prompt     = pop @lines;
 299
 300             history( "$_\n" ) for @lines;
 301         }
 302
 303         ### pose the question
 304         my $answer  = $term->readline($prompt);
 305         $answer     = $default unless length $answer;
 306
 307         $term->addhistory( $answer ) if length $answer;
 308
 309         ### add both prompt and answer to the history
 310         history( "$prompt $answer", 0 );
 311
 312         ### if we're allowed to give multiple answers, split
 313         ### the answer on whitespace
 314         my @answers = $multi ? split(/\s+/, $answer) : $answer;
 315
 316         ### the return value list
 317         my @rv;
 318
 319         if( @$choices ) {
 320
 321             for my $answer (@answers) {
 322
 323                 ### a digit implies a multiple choice question,
 324                 ### a non-digit is an open answer
 325                 if( $answer =~ /\D/ ) {
 326                     push @rv, $answer if allow( $answer, $allow );
 327                 } else {
 328
 329                     ### remember, the answer digits are +1 compared to
 330                     ### the choices, because humans want to start counting
 331                     ### at 1, not at 0
 332                     push @rv, $choices->[ $answer - 1 ]
 333                         if $answer > 0 && defined $choices->[ $answer - 1];
 334                 }
 335             }
 336
 337         ### no fixed list of choices.. just check if the answers
 338         ### (or otherwise the default!) pass the allow handler
 339         } else {
 340             push @rv, grep { allow( $_, $allow ) }
 341                         scalar @answers ? @answers : ($default);
 342         }
 343
 344         ### if not all the answers made it to the return value list,
 345         ### at least one of them was an invalid answer -- make the
 346         ### user do it again
 347         if( (@rv != @answers) or
 348             (scalar(@$choices) and not scalar(@answers))
 349         ) {
 350             $prompt = $INVALID;
 351             $prompt .= "[$prompt_add] " if $prompt_add;
 352             redo LOOP;
 353
 354         ### otherwise just return the answer, or answers, depending
 355         ### on the multi setting
 356         } else {
 357             return $multi ? @rv : $rv[0];
 358         }
 359     }
 360 }
 361
 362 =head2 ($opts, $munged) = $term->parse_options( STRING );
 363
 364 C<parse_options> will convert all options given from an input string
 365 to a hash reference. If called in list context it will also return
 366 the part of the input string that it found no options in.
 367
 368 Consider this example:
 369
 370     my $str =   q[command --no-foo --baz --bar=0 --quux=bleh ] .
 371                 q[--option="some'thing" -one-dash -single=blah' arg];
 372
 373     my ($options,$munged) =  $term->parse_options($str);
 374
 375     ### $options would contain: ###
 376     $options = {
 377                 'foo'       => 0,
 378                 'bar'       => 0,
 379                 'one-dash'  => 1,
 380                 'baz'       => 1,
 381                 'quux'      => 'bleh',
 382                 'single'    => 'blah\'',
 383                 'option'    => 'some\'thing'
 384     };
 385
 386     ### and this is the munged version of the input string,
 387     ### ie what's left of the input minus the options
 388     $munged = 'command arg';
 389
 390 As you can see, you can either use a single or a double C<-> to
 391 indicate an option.
 392 If you prefix an option with C<no-> and do not give it a value, it
 393 will be set to 0.
 394 If it has no prefix and no value, it will be set to 1.
 395 Otherwise, it will be set to its value. Note also that it can deal
 396 fine with single/double quoting issues.
 397
 398 =cut
 399
 400 sub parse_options {
 401     my $term    = shift;
 402     my $input   = shift;
 403
 404     my $return = {};
 405
 406     ### there's probably a more elegant way to do this... ###
 407     while ( $input =~ s/(?:^|\s+)--?([-\w]+=("|').+?\2)(?=\Z|\s+)//  or
 408             $input =~ s/(?:^|\s+)--?([-\w]+=\S+)(?=\Z|\s+)//         or
 409             $input =~ s/(?:^|\s+)--?([-\w]+)(?=\Z|\s+)//
 410     ) {
 411         my $match = $1;
 412
 413         if( $match =~ /^([-\w]+)=("|')(.+?)\2$/ ) {
 414             $return->{$1} = $3;
 415
 416         } elsif( $match =~ /^([-\w]+)=(\S+)$/ ) {
 417             $return->{$1} = $2;
 418
 419         } elsif( $match =~ /^no-?([-\w]+)$/i ) {
 420             $return->{$1} = 0;
 421
 422         } elsif ( $match =~ /^([-\w]+)$/ ) {
 423             $return->{$1} = 1;
 424
 425         } else {
 426             carp(loc(q[I do not understand option "%1"\n], $match)) if $VERBOSE;
 427         }
 428     }
 429
 430     return wantarray ? ($return,$input) : $return;
 431 }
 432
 433 =head2 $str = $term->history_as_string
 434
 435 Convenience wrapper around C<< Term::UI::History->history_as_string >>.
 436
 437 Consult the C<Term::UI::History> man page for details.
 438
 439 =cut
 440
 441 sub history_as_string { return Term::UI::History->history_as_string };
 442
 443 1;
 444
 445 =head1 GLOBAL VARIABLES
 446
 447 The behaviour of Term::UI can be altered by changing the following
 448 global variables:
 449
 450 =head2 $Term::UI::VERBOSE
 451
 452 This controls whether Term::UI will issue warnings and explanations
 453 as to why certain things may have failed. If you set it to 0,
 454 Term::UI will not output any warnings.
 455 The default is 1;
 456
 457 =head2 $Term::UI::AUTOREPLY
 458
 459 This will make every question be answered by the default, and warn if
 460 there was no default provided. This is particularly useful if your
 461 program is run in non-interactive mode.
 462 The default is 0;
 463
 464 =head2 $Term::UI::INVALID
 465
 466 This holds the string that will be printed when the user makes an
 467 invalid choice.
 468 You can override this string from your program if you, for example,
 469 wish to do localization.
 470 The default is C<Invalid selection, please try again: >
 471
 472 =head2 $Term::UI::History::HISTORY_FH
 473
 474 This is the filehandle all the print statements from this module
 475 are being sent to. Please consult the C<Term::UI::History> manpage
 476 for details.
 477
 478 This defaults to C<*STDOUT>.
 479
 480 =head1 EXAMPLES
 481
 482 =head2 Basic get_reply sample
 483
 484     ### ask a user (with an open question) for their favourite colour
 485     $reply = $term->get_reply( prompt => 'Your favourite colour? );
 486
 487 which would look like:
 488
 489     Your favourite colour?
 490
 491 and C<$reply> would hold the text the user typed.
 492
 493 =head2 get_reply with choices
 494
 495     ### now provide a list of choices, so the user has to pick one
 496     $reply = $term->get_reply(
 497                 prompt  => 'Your favourite colour?',
 498                 choices => [qw|red green blue|] );
 499
 500 which would look like:
 501
 502       1> red
 503       2> green
 504       3> blue
 505
 506     Your favourite colour?
 507
 508 C<$reply> will hold one of the choices presented. C<Term::UI> will repose
 509 the question if the user attempts to enter an answer that's not in the
 510 list of choices. The string presented is held in the C<$Term::UI::INVALID>
 511 variable (see the C<GLOBAL VARIABLES> section for details.
 512
 513 =head2 get_reply with choices and default
 514
 515     ### provide a sensible default option -- everyone loves blue!
 516     $reply = $term->get_reply(
 517                 prompt  => 'Your favourite colour?',
 518                 choices => [qw|red green blue|],
 519                 default => 'blue' );
 520
 521 which would look like:
 522
 523       1> red
 524       2> green
 525       3> blue
 526
 527     Your favourite colour? [3]:
 528
 529 Note the default answer after the prompt. A user can now just hit C<enter>
 530 (or set C<$Term::UI::AUTOREPLY> -- see the C<GLOBAL VARIABLES> section) and
 531 the sensible answer 'blue' will be returned.
 532
 533 =head2 get_reply using print_me & multi
 534
 535     ### allow the user to pick more than one colour and add an
 536     ### introduction text
 537     @reply = $term->get_reply(
 538                 print_me    => 'Tell us what colours you like',
 539                 prompt      => 'Your favourite colours?',
 540                 choices     => [qw|red green blue|],
 541                 multi       => 1 );
 542
 543 which would look like:
 544
 545     Tell us what colours you like
 546       1> red
 547       2> green
 548       3> blue
 549
 550     Your favourite colours?
 551
 552 An answer of C<3 2 1> would fill C<@reply> with C<blue green red>
 553
 554 =head2 get_reply & allow
 555
 556     ### pose an open question, but do a custom verification on
 557     ### the answer, which will only exit the question loop, if
 558     ### the answer matches the allow handler.
 559     $reply = $term->get_reply(
 560                 prompt  => "What is the magic number?",
 561                 allow   => 42 );
 562
 563 Unless the user now enters C<42>, the question will be reposed over
 564 and over again. You can use more sophisticated C<allow> handlers (even
 565 subroutines can be used). The C<allow> handler is implemented using
 566 C<Params::Check>'s C<allow> function. Check its manpage for details.
 567
 568 =head2 an elaborate ask_yn sample
 569
 570     ### ask a user if he likes cookies. Default to a sensible 'yes'
 571     ### and inform him first what cookies are.
 572     $bool = $term->ask_yn( prompt   => 'Do you like cookies?',
 573                            default  => 'y',
 574                            print_me => 'Cookies are LOVELY!!!' );
 575
 576 would print:
 577
 578     Cookies are LOVELY!!!
 579     Do you like cookies? [Y/n]:
 580
 581 If a user then simply hits C<enter>, agreeing with the default,
 582 C<$bool> would be set to C<true>. (Simply hitting 'y' would also
 583 return C<true>. Hitting 'n' would return C<false>)
 584
 585 We could later retrieve this interaction by printing out the Q&A
 586 history as follows:
 587
 588     print $term->history_as_string;
 589
 590 which would then print:
 591
 592     Cookies are LOVELY!!!
 593     Do you like cookies? [Y/n]:  y
 594
 595 There's a chance we're doing this non-interactively, because a console
 596 is missing, the user indicated he just wanted the defaults, etc.
 597
 598 In this case, simply setting C<$Term::UI::AUTOREPLY> to true, will
 599 return from every question with the default answer set for the question.
 600 Do note that if C<AUTOREPLY> is true, and no default is set, C<Term::UI>
 601 will warn about this and return C<undef>.
 602
 603 =head1 See Also
 604
 605 C<Params::Check>, C<Term::ReadLine>, C<Term::UI::History>
 606
 607 =head1 BUG REPORTS
 608
 609 Please report bugs or other issues to E<lt>bug-term-ui@rt.cpan.org<gt>.
 610
 611 =head1 AUTHOR
 612
 613 This module by Jos Boumans E<lt>kane@cpan.orgE<gt>.
 614
 615 =head1 COPYRIGHT
 616
 617 This library is free software; you may redistribute and/or modify it
 618 under the same terms as Perl itself.
 619
 620 =cut