File Coverage

blib/lib/Term/Form/ReadLine.pm
Criterion Covered Total %
statement 48 348 13.7
branch 3 168 1.7
condition 0 59 0.0
subroutine 15 29 51.7
pod 2 3 66.6
total 68 607 11.2


line stmt bran cond sub pod time code
1             package Term::Form::ReadLine;
2              
3 2     2   1659 use warnings;
  2         5  
  2         96  
4 2     2   15 use strict;
  2         4  
  2         44  
5 2     2   31 use 5.10.0;
  2         16  
6              
7             our $VERSION = '0.554';
8 2     2   25 use Exporter 'import';
  2         5  
  2         128  
9             our @EXPORT_OK = qw( read_line );
10              
11 2     2   1011 use parent qw( Term::Form );
  2         626  
  2         13  
12              
13 2     2   141 use Carp qw( croak );
  2         4  
  2         125  
14 2     2   13 use List::Util qw( none any );
  2         5  
  2         147  
15              
16 2     2   14 use Term::Choose::LineFold qw( line_fold print_columns );
  2         5  
  2         88  
17 2     2   12 use Term::Choose::Constants qw( :all );
  2         66  
  2         618  
18 2     2   16 use Term::Choose::Screen qw( :all );
  2         3  
  2         353  
19 2     2   14 use Term::Choose::Util qw( get_term_width get_term_height );
  2         5  
  2         95  
20 2     2   12 use Term::Choose::ValidateOptions qw( validate_options );
  2         4  
  2         188  
21              
22              
23             my $Plugin;
24              
25             BEGIN {
26 2 50   2   14 if ( $^O eq 'MSWin32' ) {
27 0         0 require Term::Choose::Win32;
28 0         0 require Win32::Console::ANSI;
29 0         0 $Plugin = 'Term::Choose::Win32';
30             }
31             else {
32 2         10 require Term::Choose::Linux;
33 2         7232 $Plugin = 'Term::Choose::Linux';
34             }
35             }
36              
37              
38             sub new {
39 1     1 1 3 my $class = shift;
40 1 50       5 croak "new: called with " . @_ . " arguments - 0 or 1 arguments expected." if @_ > 1;
41 1         3 my ( $opt ) = @_;
42 1         3 my $instance_defaults = _defaults();
43 1 50       4 if ( defined $opt ) {
44 0 0       0 croak "new: The (optional) argument is not a HASH reference." if ref $opt ne 'HASH';
45 0         0 my $caller = 'new';
46 0         0 validate_options( _valid_options(), $opt, $caller );
47 0         0 for my $key ( keys %$opt ) {
48 0 0       0 $instance_defaults->{$key} = $opt->{$key} if defined $opt->{$key};
49             }
50             }
51 1         2 my $self = bless $instance_defaults, $class;
52 1         9 $self->{backup_instance_defaults} = { %$instance_defaults };
53 1         5 $self->{plugin} = $Plugin->new();
54 1         26 return $self;
55             }
56              
57              
58             sub _valid_options {
59             return {
60 0     0   0 codepage_mapping => '[ 0 1 ]',
61             show_context => '[ 0 1 ]',
62             clear_screen => '[ 0 1 2 ]',
63             color => '[ 0 1 2 ]',
64             hide_cursor => '[ 0 1 2 ]', # hide_cursor == 2 # documentation
65             no_echo => '[ 0 1 2 ]',
66             page => '[ 0 1 2 ]', # undocumented
67             history => 'Array_Str',
68             default => 'Str',
69             footer => 'Str', # undocumented
70             info => 'Str',
71             };
72             }
73              
74              
75             sub _defaults {
76             return {
77 1     1   8 clear_screen => 0,
78             codepage_mapping => 0,
79             color => 0,
80             default => '',
81             footer => '',
82             hide_cursor => 1,
83             history => [],
84             info => '',
85             no_echo => 0,
86             page => 1,
87             show_context => 0,
88             };
89             }
90              
91              
92             sub __before_readline {
93 0     0     my ( $self, $m, $term_w ) = @_;
94 0 0         if ( $self->{show_context} ) {
95 0           my @pre_text_array;
96 0 0         if ( $m->{diff} ) {
97 0           my $line = '';
98 0           my $line_w = 0;
99 0           for my $i ( reverse( 0 .. $m->{diff} - 1 ) ) {
100 0 0         if ( $line_w + $m->{str}[$i][1] > $term_w ) {
101 0           unshift @pre_text_array, $line;
102 0           $line = $m->{str}[$i][0];
103 0           $line_w = $m->{str}[$i][1];
104             }
105             else {
106 0           $line = $m->{str}[$i][0] . $line;
107 0           $line_w = $m->{str}[$i][1] + $line_w;
108             }
109             }
110 0           my $top_pre_line_w = $self->{i}{max_key_w} + $line_w;
111 0 0         if ( $top_pre_line_w <= $term_w ) {
112 0           my $empty_w = $term_w - $top_pre_line_w;
113 0           unshift @pre_text_array, $self->{i}{prompt} . ( ' ' x $empty_w ) . $line;
114             }
115             else {
116 0           my $empty_w = $term_w - $line_w;
117 0           unshift @pre_text_array, ' ' x $empty_w . $line;
118 0           unshift @pre_text_array, $self->{i}{prompt};
119             }
120 0           $self->{i}{keys}[0] = '';
121             }
122             else {
123 0 0         if ( ( $m->{str_w} + $self->{i}{max_key_w} ) <= $term_w ) {
124 0           $self->{i}{keys}[0] = $self->{i}{prompt};
125             }
126             else {
127 0 0         if ( length $self->{i}{prompt} ) { #
128 0           unshift @pre_text_array, $self->{i}{prompt};
129             }
130 0           $self->{i}{keys}[0] = '';
131             }
132             }
133 0           $self->{i}{pre_text} = join "\n", @pre_text_array;
134 0           $self->{i}{pre_text_row_count} = scalar @pre_text_array;
135             }
136             else {
137 0           $self->{i}{keys}[0] = $self->{i}{prompt};
138             }
139             }
140              
141              
142             sub __after_readline {
143 0     0     my ( $self, $m, $term_w ) = @_;
144 0           my $count_chars_after = @{$m->{str}} - ( @{$m->{p_str}} + $m->{diff} );
  0            
  0            
145 0 0 0       if ( ! $self->{show_context} || ! $count_chars_after ) {
146 0           $self->{i}{post_text} = '';
147 0           $self->{i}{post_text_row_count} = 0;
148 0           return;
149             }
150 0           my @post_text_array;
151 0           my $line = '';
152 0           my $line_w = 0;
153 0           for my $i ( ( @{$m->{str}} - $count_chars_after ) .. $#{$m->{str}} ) {
  0            
  0            
154 0 0         if ( $line_w + $m->{str}[$i][1] > $term_w ) {
155 0           push @post_text_array, $line;
156 0           $line = $m->{str}[$i][0];
157 0           $line_w = $m->{str}[$i][1];
158 0           next;
159             }
160 0           $line = $line . $m->{str}[$i][0];
161 0           $line_w = $line_w + $m->{str}[$i][1];
162             }
163 0 0         if ( $line_w ) {
164 0           push @post_text_array, $line;
165             }
166 0           $self->{i}{post_text} = join "\n", @post_text_array;
167 0           $self->{i}{post_text_row_count} = scalar @post_text_array;
168             }
169              
170              
171             sub __print_footer {
172 0     0     my ( $self ) = @_;
173 0           my $empty = get_term_height() - $self->{i}{info_row_count} - 1;
174 0           my $footer_line = sprintf $self->{i}{footer_fmt}, $self->{i}{page_count};
175 0 0         if ( $empty > 0 ) {
176 0           print "\n" x $empty;
177 0           print $footer_line;
178 0           print up( $empty );
179             }
180             else {
181 0 0         if ( get_term_height >= 2 ) { ##
182 0           print "\n";
183 0           print $footer_line;
184 0           print up( 1 );
185             }
186             }
187             }
188              
189              
190             sub __modify_readline_options {
191 0     0     my ( $self ) = @_;
192 0 0 0       if ( length $self->{footer} && $self->{page} != 2 ) {
193 0           $self->{page} = 2;
194             }
195 0 0 0       if ( $self->{page} == 2 && $self->{clear_screen} != 1 ) {
196 0           $self->{clear_screen} = 1;
197             }
198 0           $self->{history} = [ reverse grep { length } @{$self->{history}} ];
  0            
  0            
199             }
200              
201              
202             sub __select_history {
203 0     0     my ( $self, $m, $prompt, $history_up ) = @_;
204 0 0         if ( ! @{$self->{history}} ) {
  0            
205 0           return $m;
206             }
207 0           my $current = join '', map { $_->[0] } @{$m->{str}};
  0            
  0            
208 0 0   0     if ( none { $_ eq $current } @{$self->{history}} ) {
  0            
  0            
209 0           $self->{i}{curr_string} = $current;
210             }
211 0           my @history;
212 0 0 0 0     if ( any { $_ eq $current } @{$self->{i}{prev_filtered_history}//[]} ) {
  0 0          
  0            
213 0           @history = @{$self->{i}{prev_filtered_history}}
  0            
214             }
215 0 0   0     elsif ( any { $_ =~ /^\Q$current\E/i && $_ ne $current } @{$self->{history}} ) {
  0            
216 0 0         @history = grep { $_ =~ /^\Q$current\E/i && $_ ne $current } @{$self->{history}};
  0            
  0            
217 0           @{$self->{i}{prev_filtered_history}} = @history;
  0            
218 0           $self->{i}{history_idx} = @history;
219             }
220             else {
221 0           @history = @{$self->{history}};
  0            
222 0 0 0       if ( @{$self->{i}{prev_filtered_history}//[]} ) {
  0            
223 0           $self->{i}{prev_filtered_history} = [];
224 0           $self->{i}{history_idx} = @history;
225             };
226 0 0         if ( ! defined $self->{i}{history_idx} ) {
227 0           $self->{i}{history_idx} = @history;
228             }
229             }
230 0 0         if ( ! defined $self->{i}{history_idx} ) {
231 0           $self->{i}{history_idx} = @history;
232             # first up-key pressed -> last history entry and not curr_string
233             }
234 0   0       push @history, $self->{i}{curr_string} // '';
235 0 0         if ( $history_up ) {
236 0 0         if ( $self->{i}{history_idx} == 0 ) {
237 0           $self->{i}{beep} = 1;
238             }
239             else {
240 0           --$self->{i}{history_idx};
241             }
242             }
243             else {
244 0 0         if ( $self->{i}{history_idx} >= $#history ) {
245 0           $self->{i}{beep} = 1;
246             }
247             else {
248 0           ++$self->{i}{history_idx};
249             }
250             }
251 0           my $list = [ [ $prompt, $history[$self->{i}{history_idx}] ] ];
252 0           $m = $self->__string_and_pos( $list );
253 0           return $m;
254             }
255              
256              
257             sub __prepare_prompt {
258 0     0     my ( $self, $term_w, $prompt ) = @_;
259 0 0         if ( ! length $prompt ) {
260 0           $self->{i}{prompt} = '';
261 0           $self->{i}{max_key_w} = 0;
262 0           return;
263             }
264 0           my @color;
265 0 0         if ( $self->{color} ) {
266 0           $prompt =~ s/\x{feff}//g;
267 0 0         $prompt =~ s/(\e\[[\d;]*m)/push( @color, $1 ) && "\x{feff}"/ge;
  0            
268             }
269 0           $prompt = $self->__sanitized_string( $prompt );
270 0           $self->{i}{max_key_w} = print_columns( $prompt );
271 0 0         if ( $self->{i}{max_key_w} > $term_w / 3 ) {
272 0           $self->{i}{max_key_w} = int( $term_w / 3 );
273 0           $prompt = $self->__unicode_trim( $prompt, $self->{i}{max_key_w} );
274             }
275 0 0         if ( @color ) {
276 0           $prompt =~ s/\x{feff}/shift @color/ge;
  0            
277 0           $prompt .= normal();
278             }
279 0           $self->{i}{prompt} = $prompt;
280             }
281              
282              
283             sub __init_readline {
284 0     0     my ( $self, $term_w, $prompt ) = @_;
285 0 0         if ( $self->{clear_screen} == 0 ) {
    0          
286 0           print "\r" . clear_to_end_of_screen();
287             }
288             elsif ( $self->{clear_screen} == 1 ) {
289 0           print clear_screen();
290             }
291 0 0         if ( length $self->{info} ) {
292 0           my $info_w = $term_w;
293 0 0 0       if ( $^O ne 'MSWin32' && $^O ne 'cygwin' ) {
294 0           $info_w += WIDTH_CURSOR;
295             }
296 0           my @info = line_fold( $self->{info}, $info_w, { color => $self->{color}, join => 0 } );
297 0           $self->{i}{info_row_count} = @info;
298 0 0         if ( $self->{clear_screen} == 2 ) {
299 0           print clear_to_end_of_line();
300 0           print join( "\n" . clear_to_end_of_line(), @info ), "\n";
301             }
302             else {
303 0           print join( "\n", @info ), "\n";
304             }
305             }
306             else {
307 0           $self->{i}{info_row_count} = 0;
308             }
309 0           $self->{i}{seps}[0] = $self->{i}{sep} = ''; # in __readline
310 0           $self->{i}{curr_row} = 0; # in __readlline and __string_and_pos
311 0           $self->{i}{pre_text_row_count} = 0;
312 0           $self->{i}{post_text_row_count} = 0;
313 0           $self->__prepare_prompt( $term_w, $prompt );
314 0 0         if ( $self->{show_context} ) {
315 0           $self->{i}{arrow_left} = '';
316 0           $self->{i}{arrow_right} = '';
317 0           $self->{i}{arrow_w} = 0;
318 0           $self->{i}{avail_w} = $term_w;
319             }
320             else {
321 0           $self->{i}{arrow_left} = '<';
322 0           $self->{i}{arrow_right} = '>';
323 0           $self->{i}{arrow_w} = 1;
324 0           $self->__available_width( $term_w );
325             }
326 0           $self->__threshold_width();
327 0 0         if ( $self->{page} == 2 ) {
328 0           $self->{i}{page_count} = 1;
329 0           $self->{i}{print_footer} = 1;
330 0           $self->__prepare_footer_fmt( $term_w );
331 0           $self->__print_footer();
332             }
333             else {
334 0           $self->{i}{print_footer} = 0;
335             }
336 0           my $list = [ [ $prompt, $self->{default} ] ];
337 0           my $m = $self->__string_and_pos( $list );
338 0           return $m;
339             }
340              
341              
342             sub read_line {
343 0 0   0 0   if ( ref $_[0] eq __PACKAGE__ ) {
344 0           croak "\"read_line\" is a function. The method is called \"readline\"";
345             }
346 0           my $ob = __PACKAGE__->new();
347 0           delete $ob->{backup_instance_defaults};
348 0           return $ob->readline( @_ );
349             }
350              
351              
352             sub readline {
353 0     0 1   my ( $self, $prompt, $opt ) = @_;
354 0 0         $prompt = '' if ! defined $prompt;
355 0 0         croak "readline: a reference is not a valid prompt." if ref $prompt;
356 0 0         $opt = {} if ! defined $opt;
357 0 0         if ( ! ref $opt ) {
    0          
358 0           $opt = { default => $opt };
359             }
360             elsif ( ref $opt ne 'HASH' ) {
361 0           croak "readline: the (optional) second argument must be a string or a HASH reference";
362             }
363 0 0         if ( %$opt ) {
364 0           my $caller = 'readline';
365 0           validate_options( _valid_options( $caller ), $opt, $caller );
366 0           for my $key ( keys %$opt ) {
367 0 0         $self->{$key} = $opt->{$key} if defined $opt->{$key};
368             }
369             }
370 0           $self->__modify_readline_options();
371 0 0         if ( $^O eq "MSWin32" ) {
372 0 0         print $self->{codepage_mapping} ? "\e(K" : "\e(U";
373             }
374 0           local $| = 1;
375             local $SIG{INT} = sub {
376 0     0     $self->__reset(); #
377 0           print "^C\n";
378 0           exit;
379 0           };
380 0           $self->__init_term();
381 0           my $term_w = get_term_width();
382 0           my $m = $self->__init_readline( $term_w, $prompt );
383 0           my $big_step = 10;
384 0           my $up_before = 0;
385              
386 0           CHAR: while ( 1 ) {
387 0 0         if ( $self->{i}{beep} ) {
388 0           print bell();
389 0           $self->{i}{beep} = 0;
390             }
391 0           my $tmp_term_w = get_term_width();
392 0 0         if ( $tmp_term_w != $term_w ) {
393 0           $term_w = $tmp_term_w;
394 0           $self->{default} = join( '', map { $_->[0] } @{$m->{str}} );
  0            
  0            
395 0           $m = $self->__init_readline( $term_w, $prompt );
396             }
397 0 0         if ( $self->{show_context} ) {
398 0 0         if ( ( $self->{i}{pre_text_row_count} + 2 + $self->{i}{post_text_row_count} ) >= get_term_height() ) { ##
399 0           $self->{show_context} = 0;
400 0           $up_before = 0;
401 0           $self->{default} = join( '', map { $_->[0] } @{$m->{str}} );
  0            
  0            
402 0           $m = $self->__init_readline( $term_w, $prompt );
403             }
404 0           $self->{i}{context_count} = $self->{i}{pre_text_row_count} + $self->{i}{post_text_row_count};
405             }
406 0 0         if ( $up_before ) {
407 0           print up( $up_before );
408             }
409 0           my $p = "\r" . clear_to_end_of_line();
410 0 0 0       if ( $self->{i}{prev_context_count} || $self->{i}{context_count} ) {
411             my $count = $self->{i}{prev_context_count} // 0 > $self->{i}{context_count} // 0
412             ? $self->{i}{prev_context_count}
413 0 0 0       : $self->{i}{context_count};
      0        
414 0           ++$count; # Home
415 0           $p .= ( down( 1 ) . clear_to_end_of_line() ) x $count;
416 0           $p .= up( $count );
417             }
418 0           print $p;
419 0           $self->__before_readline( $m, $term_w );
420 0           $up_before = $self->{i}{pre_text_row_count};
421 0 0         if ( $self->{hide_cursor} ) {
422 0           print hide_cursor();
423             }
424 0 0         if ( length $self->{i}{pre_text} ) {
425 0           print $self->{i}{pre_text}, "\n";
426             }
427              
428 0           $self->__after_readline( $m, $term_w );
429 0 0         if ( length $self->{i}{post_text} ) {
430 0           print "\n" . $self->{i}{post_text};
431             }
432 0 0         if ( $self->{i}{post_text_row_count} ) {
433 0           print up( $self->{i}{post_text_row_count} );
434             }
435 0           $self->{i}{prev_context_count} = $self->{i}{context_count};
436 0           $self->__print_readline( $m );
437 0           my $char = $self->{plugin}->__get_key_OS();
438 0 0         if ( ! defined $char ) {
439 0           $self->__reset();
440 0           warn "EOT: $!";
441 0           return;
442             }
443             # reset $m->{avail_w} to default:
444 0           $m->{avail_w} = $self->{i}{avail_w};
445 0           $self->__threshold_char_count( $m );
446 0 0 0       if ( $char == NEXT_get_key ) { next CHAR }
  0 0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
447 0           elsif ( $char == KEY_TAB ) { next CHAR }
448 0 0         elsif ( $char == VK_PAGE_UP || $char == CONTROL_P ) { for ( 1 .. $big_step ) { last if $m->{pos} == 0; $self->__left( $m ) } }
  0            
  0            
449 0 0         elsif ( $char == VK_PAGE_DOWN || $char == CONTROL_N ) { for ( 1 .. $big_step ) { last if $m->{pos} == @{$m->{str}}; $self->__right( $m ) } }
  0            
  0            
  0            
450 0           elsif ( $char == CONTROL_U ) { $self->__ctrl_u( $m ) }
451 0           elsif ( $char == CONTROL_K ) { $self->__ctrl_k( $m ) }
452 0           elsif ( $char == VK_RIGHT || $char == CONTROL_F ) { $self->__right( $m ) }
453 0           elsif ( $char == VK_LEFT || $char == CONTROL_B ) { $self->__left( $m ) }
454 0           elsif ( $char == VK_END || $char == CONTROL_E ) { $self->__end( $m ) }
455 0           elsif ( $char == VK_HOME || $char == CONTROL_A ) { $self->__home( $m ) }
456 0           elsif ( $char == KEY_BSPACE || $char == CONTROL_H ) { $self->__bspace( $m ) }
457 0           elsif ( $char == VK_DELETE || $char == CONTROL_D ) { $self->__delete( $m ) }
458 0           elsif ( $char == VK_UP || $char == CONTROL_S ) { $m = $self->__select_history( $m, $prompt, 1 ) }
459 0           elsif ( $char == VK_DOWN || $char == CONTROL_T ) { $m = $self->__select_history( $m, $prompt, 0 ) }
460             elsif ( $char == CONTROL_X ) {
461 0 0         if ( @{$m->{str}} ) {
  0            
462 0           my $list = [ [ $prompt, '' ] ];
463 0           $m = $self->__string_and_pos( $list );
464             }
465             else {
466 0           $self->__reset( $self->{i}{info_row_count} + $self->{i}{pre_text_row_count} );
467 0           return;
468             }
469             }
470             elsif ( $char == VK_INSERT ) {
471 0           $self->{i}{beep} = 1;
472             }
473             elsif ( $char == LINE_FEED || $char == CARRIAGE_RETURN ) {
474             # LINE_FEED == CONTROL_J, CARRIAGE_RETURN == CONTROL_M
475 0           $self->__reset( $self->{i}{info_row_count} + $self->{i}{pre_text_row_count} );
476 0           return join( '', map { $_->[0] } @{$m->{str}} );
  0            
  0            
477             }
478             else {
479 0           $char = chr $char;
480 0           utf8::upgrade $char;
481 0           $self->__add_char( $m, $char );
482             }
483             }
484             }
485              
486              
487             1;
488              
489             __END__