136f75bb6ad3323e59c35c91f873c2f2d9171ca2
[perl.git] / 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.20';
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 (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