[Summary view] [Print] [Text view]

   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.18';
  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 seperately 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 $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