Commit | Line | Data |
4f08f5ad |
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; |
ce5e090c |
14 | $VERSION = '0.16'; |
4f08f5ad |
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... ### |
ce5e090c |
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+)// |
4f08f5ad |
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 | |
ce5e090c |
607 | =head1 BUG REPORTS |
608 | |
609 | Please report bugs or other issues to E<lt>bug-term-ui@rt.cpan.org<gt>. |
610 | |
4f08f5ad |
611 | =head1 AUTHOR |
612 | |
ce5e090c |
613 | This module by Jos Boumans E<lt>kane@cpan.orgE<gt>. |
4f08f5ad |
614 | |
615 | =head1 COPYRIGHT |
616 | |
ce5e090c |
617 | This library is free software; you may redistribute and/or modify it |
618 | under the same terms as Perl itself. |
4f08f5ad |
619 | |
ce5e090c |
620 | =cut |