File Coverage

lib/Class/Usul/TraitFor/Prompting.pm
Criterion Covered Total %
statement 71 81 87.6
branch 15 34 44.1
condition 11 31 35.4
subroutine 12 12 100.0
pod 5 5 100.0
total 114 163 69.9


line stmt bran cond sub pod time code
1             package Class::Usul::TraitFor::Prompting;
2              
3 18     18   11012 use namespace::autoclean;
  18         60  
  18         167  
4              
5 18     18   1608 use Class::Usul::Constants qw( BRK FAILED FALSE NO NUL QUIT SPC TRUE YES );
  18         43  
  18         164  
6 18     18   21376 use Class::Usul::Functions qw( arg_list emit_to is_hashref pad throw );
  18         59  
  18         166  
7 18     18   30193 use English qw( -no_match_vars );
  18         71  
  18         203  
8 18     18   18781 use IO::Interactive;
  18         11774  
  18         120  
9 18     18   8928 use Term::ReadKey;
  18         29377  
  18         1812  
10 18     18   207 use Moo::Role;
  18         54  
  18         254  
11              
12             requires qw( add_leader config loc output );
13              
14             # Private functions
15             my $_default_input = sub {
16             my ($fh, $args) = @_;
17              
18             ($ENV{PERL_MM_USE_DEFAULT} or $ENV{PERL_MB_USE_DEFAULT})
19             and return $args->{default};
20             $args->{onechar} and return getc $fh;
21             return scalar <$fh>;
22             };
23              
24             my $_get_control_chars = sub {
25             # Returns a string of pipe separated control
26             # characters and a hash of symbolic names and values
27             my $handle = shift; my %cntl = GetControlChars $handle;
28              
29             return ((join '|', values %cntl), %cntl);
30             };
31              
32             my $_justify_count = sub {
33             return pad $_[ 1 ], int log $_[ 0 ] / log 10, SPC, 'left';
34             };
35              
36             my $_map_prompt_args = sub { # IO::Prompt equiv. sub has an obscure bug so this
37             my $args = shift; my %map = ( qw(-1 onechar -d default -e echo -p prompt) );
38              
39             for (grep { exists $map{ $_ } } keys %{ $args }) {
40             $args->{ $map{ $_ } } = delete $args->{ $_ };
41             }
42              
43             return $args;
44             };
45              
46             my $_opts = sub {
47             my ($type, @args) = @_; is_hashref $args[ 0 ] and return $args[ 0 ];
48              
49             my $attr = { default => $args[ 0 ], quit => $args[ 1 ], width => $args[ 2 ]};
50              
51             if ($type eq 'get_line') {
52             $attr->{multiline} = $args[ 3 ]; $attr->{noecho} = $args[ 4 ];
53             }
54             elsif ($type eq 'get_option') { $attr->{options} = $args[ 3 ] }
55             elsif ($type eq 'yorn') { $attr->{newline} = $args[ 3 ] }
56              
57             return $attr;
58             };
59              
60             my $_raw_mode = sub { # Puts the terminal in raw input mode
61             my $handle = shift; ReadMode 'raw', $handle; return;
62             };
63              
64             my $_restore_mode = sub { # Restores line input mode to the terminal
65             my $handle = shift; ReadMode 'restore', $handle; return;
66             };
67              
68             my $_prompt = sub {
69             # This was taken from L<IO::Prompt> which has an obscure bug in it
70             my $args = $_map_prompt_args->( arg_list @_ );
71             my $default = $args->{default};
72             my $echo = $args->{echo };
73             my $onechar = $args->{onechar};
74             my $OUT = \*STDOUT;
75             my $IN = \*STDIN;
76             my $input = NUL;
77              
78             my ($len, $newlines, $next, $text);
79              
80             IO::Interactive::is_interactive() or return $_default_input->( $IN, $args );
81              
82             my ($cntl, %cntl) = $_get_control_chars->( $IN );
83             local $SIG{INT} = sub { $_restore_mode->( $IN ); exit FAILED };
84              
85             emit_to $OUT, $args->{prompt}; $_raw_mode->( $IN );
86              
87             while (TRUE) {
88             if (defined ($next = getc $IN)) {
89             if ($next eq $cntl{INTERRUPT}) {
90             $_restore_mode->( $IN ); exit FAILED;
91             }
92             elsif ($next eq $cntl{ERASE}) {
93             if ($len = length $input) {
94             $input = substr $input, 0, $len - 1; emit_to $OUT, "\b \b";
95             }
96              
97             next;
98             }
99             elsif ($next eq $cntl{EOF}) {
100             $_restore_mode->( $IN );
101             close $IN or throw 'IO error: [_1]', [ $OS_ERROR ];
102             return $input;
103             }
104             elsif ($next !~ m{ $cntl }mx) {
105             $input .= $next;
106              
107             if ($next eq "\n") {
108             if ($input eq "\n" and defined $default) {
109             $text = defined $echo ? $echo x length $default : $default;
110             emit_to $OUT, "[${text}]\n"; $_restore_mode->( $IN );
111              
112             return $onechar ? substr $default, 0, 1 : $default;
113             }
114              
115             $newlines .= "\n";
116             }
117             else { emit_to $OUT, $echo // $next }
118             }
119             else { $input .= $next }
120             }
121              
122             if ($onechar or not defined $next or $input =~ m{ \Q$RS\E \z }mx) {
123             chomp $input; $_restore_mode->( $IN );
124             defined $newlines and emit_to $OUT, $newlines;
125             return $onechar ? substr $input, 0, 1 : $input;
126             }
127             }
128              
129             return;
130             };
131              
132             # Private methods
133             my $_prepare = sub {
134             my ($self, $question) = @_; my $add_leader;
135              
136             '+' eq substr $question, 0, 1 and $add_leader = TRUE
137             and $question = substr $question, 1;
138             $question = $self->loc( $question );
139             $add_leader and $question = $self->add_leader( $question );
140             return $question;
141             };
142              
143             # Public methods
144             sub anykey {
145 1     1 1 658 my ($self, $prompt) = @_;
146              
147 1   50     8 $prompt = $self->$_prepare( $prompt // 'Press any key to continue' );
148              
149 1         9 return $_prompt->( -p => "${prompt}...", -d => TRUE, -e => NUL, -1 => TRUE );
150             }
151              
152             sub get_line { # General text input routine.
153 2     2 1 8 my ($self, $question, @args) = @_; my $opts = $_opts->( 'get_line', @args );
  2         8  
154              
155 2   100     12 $question = $self->$_prepare( $question // 'Enter your answer' );
156              
157 2   50     11 my $default = $opts->{default} // NUL;
158 2 50       9 my $advice = $opts->{quit} ? $self->loc( '([_1] to quit)', QUIT ) : NUL;
159 2 50       12 my $r_prompt = $advice.($opts->{multiline} ? NUL : " [${default}]");
160 2         4 my $l_prompt = $question;
161              
162 2 50       9 if (defined $opts->{width}) {
163 0   0     0 my $total = $opts->{width} || $self->config->pwidth;
164 0         0 my $left_x = $total - (length $r_prompt);
165              
166 0         0 $l_prompt = sprintf '%-*s', $left_x, $question;
167             }
168              
169             my $prompt = "${l_prompt} ${r_prompt}"
170 2 50       13 . ($opts->{multiline} ? "\n[${default}]" : NUL).BRK;
171             my $result = $opts->{noecho}
172 2 50       12 ? $_prompt->( -d => $default, -p => $prompt, -e => '*' )
173             : $_prompt->( -d => $default, -p => $prompt );
174              
175 2 0 33     17 $opts->{quit} and defined $result and lc $result eq QUIT and exit FAILED;
      33        
176              
177 2         13 return "${result}";
178             }
179              
180             sub get_option { # Select from an numbered list of options
181 1     1 1 4 my ($self, $prompt, @args) = @_; my $opts = $_opts->( 'get_option', @args );
  1         4  
182              
183 1   50     7 $prompt //= '+Select one option from the following list:';
184              
185 1 50       4 my $no_lead = ('+' eq substr $prompt, 0, 1) ? FALSE : TRUE;
186 1 50       3 my $leader = $no_lead ? NUL : '+'; $prompt =~ s{ \A \+ }{}mx;
  1         6  
187 1   50     2 my $max = @{ $opts->{options} // [] };
  1         7  
188              
189 1         6 $self->output( $prompt, { no_lead => $no_lead } ); my $count = 1;
  1         3  
190              
191 0         0 my $text = join "\n", map { $_justify_count->( $max, $count++ )." - ${_}" }
192 1   50     2 @{ $opts->{options} // [] };
  1         9  
193              
194 1         6 $self->output( $text, { cl => TRUE, nl => TRUE, no_lead => $no_lead } );
195              
196 1         7 my $question = "${leader}Select option";
197 1         7 my $opt = $self->get_line( $question, $opts );
198              
199 1 50 0     7 $opt !~ m{ \A \d+ \z }mx and $opt = $opts->{default} // 0;
200              
201 1         8 return $opt - 1;
202             }
203              
204             sub is_interactive {
205 1     1 1 43 my $self = shift; return IO::Interactive::is_interactive( @_ );
  1         6  
206             }
207              
208             sub yorn { # General yes or no input routine
209 1     1 1 6 my ($self, $question, @args) = @_; my $opts = $_opts->( 'yorn', @args );
  1         6  
210              
211 1   50     7 $question = $self->$_prepare( $question // 'Choose' );
212              
213 1         3 my $no = NO; my $yes = YES; my $result;
  1         4  
  1         2  
214              
215 1 50       4 my $default = $opts->{default} ? $yes : $no;
216 1 50       4 my $quit = $opts->{quit } ? QUIT : NUL;
217 1 50       4 my $advice = $quit ? "(${yes}/${no}, ${quit}) " : "(${yes}/${no}) ";
218 1         3 my $r_prompt = "${advice}[${default}]";
219 1         4 my $l_prompt = $question;
220              
221 1 50       3 if (defined $opts->{width}) {
222 0   0     0 my $max_width = $opts->{width} || $self->config->pwidth;
223 0         0 my $right_x = length $r_prompt;
224 0         0 my $left_x = $max_width - $right_x;
225              
226 0         0 $l_prompt = sprintf '%-*s', $left_x, $question;
227             }
228              
229 1 50       6 my $prompt = "${l_prompt} ${r_prompt}".BRK.($opts->{newline} ? "\n" : NUL);
230              
231 1         4 while ($result = $_prompt->( -d => $default, -p => $prompt )) {
232 1 50 33     7 $quit and $result =~ m{ \A (?: $quit | [\e] ) }imx and exit FAILED;
233 1 50       18 $result =~ m{ \A $yes }imx and return TRUE;
234 0 0         $result =~ m{ \A $no }imx and return FALSE;
235             }
236              
237 0           return;
238             }
239              
240             1;
241              
242             __END__
243              
244             =pod
245              
246             =encoding utf8
247              
248             =head1 Name
249              
250             Class::Usul::TraitFor::Prompting - Methods for requesting command line input
251              
252             =head1 Synopsis
253              
254             use Moo;
255              
256             with q(Class::Usul::TraitForPrompting);
257              
258             =head1 Description
259              
260             Methods that prompt for command line input from the user
261              
262             =head1 Configuration and Environment
263              
264             Defines no attributes
265              
266             =head1 Subroutines/Methods
267              
268             =head2 anykey
269              
270             $key = $self->anykey( $prompt );
271              
272             Prompt string defaults to 'Press any key to continue...'. Calls and
273             returns L<prompt|/__prompt>. Requires the user to press any key on the
274             keyboard (that generates a character response)
275              
276             =head2 get_line
277              
278             $line = $self->get_line( $question, $default, $quit, $width, $newline );
279              
280             Prompts the user to enter a single line response to C<$question> which
281             is printed to I<STDOUT> with a program leader. If C<$quit> is true
282             then the options to quit is included in the prompt. If the C<$width>
283             argument is defined then the string is formatted to the specified
284             width which is C<$width> or C<< $self->pwdith >> or 40. If C<$newline>
285             is true a newline character is appended to the prompt so that the user
286             get a full line of input
287              
288             =head2 get_option
289              
290             $option = $self->get_option( $question, $default, $quit, $width, $options );
291              
292             Returns the selected option number from the list of possible options passed
293             in the C<$question> argument
294              
295             =head2 is_interactive
296              
297             $bool = $self->is_interactive( $optional_filehandle );
298              
299             Exposes L<IO::Interactive/is_interactive>
300              
301             =head2 yorn
302              
303             $self->yorn( $question, $default, $quit, $width );
304              
305             Prompt the user to respond to a yes or no question. The C<$question>
306             is printed to I<STDOUT> with a program leader. The C<$default>
307             argument is C<0|1>. If C<$quit> is true then the option to quit is
308             included in the prompt. If the C<$width> argument is defined then the
309             string is formatted to the specified width which is C<$width> or
310             C<< $self->pwdith >> or 40
311              
312             =head1 Diagnostics
313              
314             None
315              
316             =head1 Dependencies
317              
318             =over 3
319              
320             =item L<IO::Interactive>
321              
322             =item L<Term::ReadKey>
323              
324             =back
325              
326             =head1 Incompatibilities
327              
328             There are no known incompatibilities in this module
329              
330             =head1 Bugs and Limitations
331              
332             There are no known bugs in this module. Please report problems to
333             http://rt.cpan.org/NoAuth/Bugs.html?Dist=Class-Usul.
334             Patches are welcome
335              
336             =head1 Acknowledgements
337              
338             Larry Wall - For the Perl programming language
339              
340             =head1 Author
341              
342             Peter Flanigan, C<< <pjfl@cpan.org> >>
343              
344             =head1 License and Copyright
345              
346             Copyright (c) 2017 Peter Flanigan. All rights reserved
347              
348             This program is free software; you can redistribute it and/or modify it
349             under the same terms as Perl itself. See L<perlartistic>
350              
351             This program is distributed in the hope that it will be useful,
352             but WITHOUT WARRANTY; without even the implied warranty of
353             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE
354              
355             =cut
356              
357             # Local Variables:
358             # mode: perl
359             # tab-width: 3
360             # End: