File Coverage

lib/Term/UI.pm
Criterion Covered Total %
statement 27 128 21.0
branch 0 78 0.0
condition 0 36 0.0
subroutine 9 14 64.2
pod 4 4 100.0
total 40 260 15.3


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