File Coverage

blib/lib/Term/Choose/Util.pm
Criterion Covered Total %
statement 44 556 7.9
branch 0 278 0.0
condition 0 58 0.0
subroutine 15 38 39.4
pod 7 13 53.8
total 66 943 7.0


line stmt bran cond sub pod time code
1             package Term::Choose::Util;
2              
3 1     1   80932 use warnings;
  1         2  
  1         25  
4 1     1   4 use strict;
  1         11  
  1         17  
5 1     1   13 use 5.10.0;
  1         3  
6              
7             our $VERSION = '0.138';
8 1     1   4 use Exporter 'import';
  1         7  
  1         66  
9             our @EXPORT_OK = qw( choose_a_directory choose_a_file choose_directories choose_a_number choose_a_subset settings_menu
10             insert_sep get_term_size get_term_width get_term_height unicode_sprintf );
11              
12 1     1   5 use Carp qw( croak );
  1         1  
  1         38  
13 1     1   4 use Cwd qw( realpath );
  1         4  
  1         39  
14 1     1   1315 use Encode qw( decode encode );
  1         8782  
  1         54  
15 1     1   6 use File::Basename qw( basename dirname );
  1         1  
  1         86  
16 1     1   362 use File::Spec::Functions qw( catdir catfile );
  1         736  
  1         48  
17 1     1   10 use List::Util qw( sum any );
  1         2  
  1         95  
18              
19 1     1   394 use Encode::Locale qw();
  1         2739  
  1         18  
20 1     1   1141 use File::HomeDir qw();
  1         5915  
  1         22  
21              
22 1     1   564 use Term::Choose qw( choose );
  1         110542  
  1         112  
23 1     1   23 use Term::Choose::LineFold qw( cut_to_printwidth print_columns );
  1         2  
  1         63  
24 1     1   6 use Term::Choose::ValidateOptions qw( validate_options );
  1         2  
  1         5825  
25              
26              
27             sub new {
28 0     0 1   my $class = shift;
29 0           my ( $opt ) = @_;
30 0           my $instance_defaults = _defaults();
31 0 0         if ( defined $opt ) {
32 0 0         croak "Options have to be passed as a HASH reference." if ref $opt ne 'HASH';
33 0           my $caller = 'new';
34 0           validate_options( _valid_options( $caller ), $opt, $caller );
35 0           for my $key ( keys %$opt ) {
36 0 0         $instance_defaults->{$key} = $opt->{$key} if defined $opt->{$key};
37             }
38             }
39 0           my $self = bless $instance_defaults, $class;
40 0           $self->{backup_instance_defaults} = { %$instance_defaults };
41 0           return $self;
42             }
43              
44              
45             sub __restore_defaults {
46 0     0     my ( $self ) = @_;
47 0 0         if ( exists $self->{backup_instance_defaults} ) {
48 0           my $instance_defaults = $self->{backup_instance_defaults};
49 0           for my $key ( keys %$self ) {
50 0 0         if ( $key eq 'backup_instance_defaults' ) {
    0          
51 0           next;
52             }
53             elsif ( exists $instance_defaults->{$key} ) {
54 0           $self->{$key} = $instance_defaults->{$key};
55             }
56             else {
57 0           delete $self->{$key};
58             }
59             }
60             }
61             }
62              
63              
64             sub __prepare_opt {
65 0     0     my ( $self, $opt, $subseq_tab ) = @_;
66 0 0         if ( ! defined $opt ) {
67 0           $opt = {};
68             }
69 0 0         croak "Options have to be passed as a HASH reference." if ref $opt ne 'HASH';
70 0 0         if ( %$opt ) {
71 0           my $caller = ( caller( 1 ) )[3];
72 0           $caller =~ s/^.+::(?:__)?([^:]+)\z/$1/;
73 0           validate_options( _valid_options( $caller ), $opt, $caller );
74 0           my $defaults = _defaults();
75 0           for my $key ( keys %$opt ) {
76 0 0 0       if ( ! defined $opt->{$key} && defined $defaults->{$key} ) {
77 0           $self->{$key} = $defaults->{$key};
78             }
79             else {
80 0           $self->{$key} = $opt->{$key};
81             }
82             }
83             }
84 0 0         if ( ! defined $self->{tabs_info} ) {
85 0 0         if ( defined $self->{margin} ) {
86 0   0       $self->{tabs_info} = [ $self->{margin}[3] // 0, $self->{margin}[3] // 0, $self->{margin}[1] // 0 ];
      0        
      0        
87             }
88             }
89 0 0         if ( ! defined $self->{tabs_prompt} ) {
90 0 0         if ( defined $self->{margin} ) {
    0          
91             $self->{tabs_prompt} = [
92             $self->{margin}[3] // 0,
93             ( $self->{margin}[3] // 0 ) + ( $subseq_tab // 0 ),
94 0   0       $self->{margin}[1] // 0
      0        
      0        
      0        
95             ];
96             }
97             elsif ( $subseq_tab ) {
98 0           $self->{tabs_prompt} = [ 0, $subseq_tab, 0 ];
99             }
100             }
101             }
102              
103              
104             sub _valid_options {
105 0     0     my ( $caller ) = @_;
106 0           my %valid = (
107             all_by_default => '[ 0 1 ]',
108             clear_screen => '[ 0 1 ]',
109             decoded => '[ 0 1 ]',
110             hide_cursor => '[ 0 1 ]',
111             index => '[ 0 1 ]',
112             keep_chosen => '[ 0 1 ]',
113             mouse => '[ 0 1 ]',
114             order => '[ 0 1 ]',
115             show_hidden => '[ 0 1 ]',
116             small_first => '[ 0 1 ]',
117             alignment => '[ 0 1 2 ]',
118             color => '[ 0 1 2 ]',
119             layout => '[ 0 1 2 ]',
120             page => '[ 0 1 2 ]', # undocumented
121             keep => '[ 1-9 ][ 0-9 ]*', # undocumented
122             default_number => '[ 0-9 ]+',
123             margin => 'Array_Int',
124             mark => 'Array_Int',
125             tabs_info => 'Array_Int',
126             tabs_prompt => 'Array_Int',
127             busy_string => 'Str',
128             info => 'Str',
129             init_dir => 'Str',
130             back => 'Str',
131             file_type => 'Str', # undocumented
132             filter => 'Str',
133             footer => 'Str', # undocumented
134             confirm => 'Str',
135             prefix => 'Str',
136             prompt => 'Str',
137             prompt_file_dir => 'Str', # undocumented
138             cs_begin => 'Str',
139             cs_end => 'Str',
140             cs_label => 'Str',
141             cs_separator => 'Str',
142             thousands_separator => 'Str',
143             );
144 0           my $options;
145 0 0         if ( $caller eq 'new' ) {
146 0           $options = [ keys %valid ];
147             }
148             else {
149 0           $options = _routine_options( $caller );
150             }
151 0           return { map { $_ => $valid{$_} } @$options };
  0            
152             };
153              
154              
155             sub _defaults {
156             return {
157 0     0     alignment => 0,
158             all_by_default => 0,
159             back => 'BACK',
160             #busy_string => undef,
161             clear_screen => 0,
162             color => 0,
163             confirm => 'CONFIRM',
164             cs_begin => '',
165             cs_end => '',
166             #cs_label => undef,
167             cs_separator => ', ',
168             decoded => 1,
169             #default_number => undef,
170             file_type => 'File',
171             #filter => undef,
172             #footer => undef,
173             hide_cursor => 1,
174             index => 0,
175             #info => undef,
176             #init_dir => undef,
177             keep_chosen => 0,
178             #keep => undef,
179             layout => 1,
180             #margin => undef,
181             #mark => undef,
182             mouse => 0,
183             order => 1,
184             #page => undef,
185             parent_dir => '..',
186             prefix => '',
187             prompt => 'Your choice: ',
188             prompt_file_dir => 'Choose the file directory:',
189             show_hidden => 1,
190             small_first => 0,
191             #tabs_info => undef,
192             #tabs_prompt => undef,
193             thousands_separator => ',',
194              
195             ## intern:
196             reset => 'reset',
197             };
198             };
199              
200              
201             sub _routine_options {
202 0     0     my ( $caller ) = @_;
203 0           my @every = ( qw( back clear_screen color confirm cs_label footer hide_cursor info keep margin mouse page prompt tabs_info tabs_prompt ) );
204 0           my $options;
205 0 0         if ( $caller eq 'choose_directories' ) {
    0          
    0          
    0          
    0          
    0          
206 0           $options = [ @every, qw( init_dir layout order alignment show_hidden decoded ) ];
207             }
208             elsif ( $caller eq 'choose_a_directory' ) {
209 0           $options = [ @every, qw( init_dir layout order alignment show_hidden decoded ) ];
210             }
211             elsif ( $caller eq 'choose_a_file' ) {
212 0           $options = [ @every, qw( init_dir layout order alignment show_hidden decoded filter prompt_file_dir file_type ) ];
213             }
214             elsif ( $caller eq 'choose_a_number' ) {
215 0           $options = [ @every, qw( small_first reset thousands_separator default_number ) ];
216             }
217             elsif ( $caller eq 'choose_a_subset' ) {
218 0           $options = [ @every, qw( layout order alignment keep_chosen index prefix all_by_default cs_begin cs_end cs_separator mark busy_string ) ];
219             }
220             elsif ( $caller eq 'settings_menu' ) {
221 0           $options = [ @every, qw( cs_begin cs_end cs_separator ) ];
222             }
223 0           return $options;
224             }
225              
226              
227             sub __prepare_path {
228 0     0     my ( $self ) = @_;
229 0           my $init_dir_fs;
230 0 0         if ( defined $self->{init_dir} ) {
231 0           $init_dir_fs = encode( 'locale_fs', $self->{init_dir} );
232 0 0         if ( ! -d $init_dir_fs ) {
233 0           my $prompt = 'Could not find the directory "';
234 0           $prompt .= decode 'locale_fs', $init_dir_fs;
235 0           $prompt .= '". Falling back to the home directory.';
236             # Choose
237             choose(
238             [ 'Press ENTER to continue' ],
239             { prompt => $prompt, hide_cursor => $self->{hide_cursor}, mouse => $self->{mouse}, page => $self->{page},
240             footer => $self->{footer}, keep => $self->{keep} }
241 0           );
242 0           $init_dir_fs = File::HomeDir->my_home();
243             }
244             }
245             else {
246 0           $init_dir_fs = File::HomeDir->my_home();
247             }
248 0 0         if ( ! -d $init_dir_fs ) {
249 0           croak "Could not find the home directory.";
250             }
251 0           my $dir_fs = realpath $init_dir_fs;
252 0           my $dir = decode( 'locale_fs', $dir_fs );
253 0           return $dir;
254             }
255              
256              
257             sub __available_dirs {
258 0     0     my ( $self, $dir ) = @_;
259 0           my $dir_fs = encode( 'locale_fs', $dir );
260 0           my $dh;
261 0 0         if ( ! eval {
262 0 0         opendir( $dh, $dir_fs ) or croak $!;
263 0           1 }
264             ) {
265 0           print "$@";
266             # Choose
267             choose(
268             [ 'Press Enter:' ],
269             { prompt => '', hide_cursor => $self->{hide_cursor}, mouse => $self->{mouse}, page => $self->{page},
270             footer => $self->{footer}, keep => $self->{keep}, margin => $self->{margin} }
271 0           );
272 0           return;
273             }
274 0           my @dirs;
275 0           while ( my $file_fs = readdir $dh ) {
276 0 0         next if $file_fs =~ /^\.\.?\z/;
277 0 0 0       next if $file_fs =~ /^\./ && ! $self->{show_hidden};
278 0 0         if ( -d catdir $dir_fs, $file_fs ) {
279 0           push @dirs, decode( 'locale_fs', $file_fs );
280             }
281             }
282 0           closedir $dh;
283 0           return [ sort @dirs ];
284             }
285              
286              
287             sub choose_directories {
288 0 0   0 1   if ( ref $_[0] ne __PACKAGE__ ) {
289 0           my $ob = __PACKAGE__->new();
290 0           delete $ob->{backup_instance_defaults};
291 0           return $ob->choose_directories( @_ );
292             }
293 0           my ( $self, $opt ) = @_;
294 0           my $subseq_tab = 2;
295 0           $self->__prepare_opt( $opt, $subseq_tab );
296 0           my $dir = $self->__prepare_path();
297 0           my $chosen_dirs = [];
298 0           my ( $confirm, $change_path, $add_dirs ) = ( ' ' . $self->{confirm}, '- Change Location', '- Add Directories' );
299 0           my @bu;
300              
301 0           CHOOSE_MODE: while ( 1 ) {
302 0   0       my $key_dirs = $self->{cs_label} // 'Chosen Dirs: ';
303 0 0         my $dirs_chosen = $key_dirs . ( @$chosen_dirs ? join( ', ', @$chosen_dirs ) : '---' );
304 0           my $key_path = 'Location: ';
305 0           my $path = $key_path . $dir;
306 0           my $prompt = $dirs_chosen . "\n" . $path;
307             # Choose
308             my $choice = choose(
309             [ undef, $confirm, $change_path, $add_dirs ],
310             { info => $self->{info}, prompt => $prompt, layout => 2, mouse => $self->{mouse}, margin => $self->{margin},
311             clear_screen => $self->{clear_screen}, hide_cursor => $self->{hide_cursor}, page => $self->{page},
312             footer => $self->{footer}, keep => $self->{keep}, undef => ' ' . $self->{back},
313             tabs_info => $self->{tabs_info}, tabs_prompt => $self->{tabs_prompt} }
314 0           );
315 0 0         if ( ! defined $choice ) {
    0          
    0          
    0          
316 0 0         if ( @bu ) {
317 0           ( $dir, $chosen_dirs ) = @{pop @bu};
  0            
318 0           next CHOOSE_MODE;
319             }
320 0           $self->__restore_defaults(); #
321 0           return;
322             }
323             elsif ( $choice eq $confirm ) {
324 0           my $decoded = $self->{decoded};
325 0           $self->__restore_defaults();
326 0 0         return $decoded ? $chosen_dirs : [ map { encode 'locale_fs', $_ } @$chosen_dirs ];
  0            
327             }
328             elsif ( $choice eq $change_path ) {
329 0           my $prompt_fmt = $key_path . "%s";
330 0 0         if ( length $self->{prompt} ) {
331 0           $prompt_fmt .= "\n" . $self->{prompt};
332             }
333 0           my $tmp_dir = $self->__choose_a_path( $dir, $prompt_fmt, '<<', 'OK' );
334 0 0         if ( defined $tmp_dir ) {
335 0           $dir = $tmp_dir;
336             }
337             }
338             elsif ( $choice eq $add_dirs ) {
339 0           my $avail_dirs = $self->__available_dirs( $dir );
340 0 0         if ( ! defined $avail_dirs ) {
341 0           next CHOOSE_MODE;
342             }
343 0           my %bu_opt;
344 0           my $options = _routine_options( 'choose_directories' );
345 0           for my $o ( @$options ) {
346 0           $bu_opt{$o} = $self->{$o};
347             }
348 0           my $cs_label = $dirs_chosen . "\n" . $path . "\n" . 'Dirs to add: ';
349             # choose_a_subset
350 0           my $idxs = $self->choose_a_subset(
351             [ sort @$avail_dirs ],
352             { cs_label => $cs_label, back => '<<', confirm => 'OK', cs_begin => undef,index => 1,
353             #info => $self->{info}, prompt => $self->{prompt}, page => $self->{page}, footer => $self->{footer},
354             #keep => $self->{keep}, margin => $self->{margin}, tabs_info => $self->{tabs_info},
355             #tabs_prompt => $self->{tabs_prompt}
356             }
357             );
358 0           for my $o ( keys %bu_opt ) {
359 0           $self->{$o} = $bu_opt{$o};
360             }
361 0 0 0       if ( defined $idxs && @$idxs ) {
362 0           push @bu, [ $dir, [ @$chosen_dirs ] ];
363 0           push @$chosen_dirs, map { catdir $dir, $_ } @{$avail_dirs}[@$idxs];
  0            
  0            
364             }
365             }
366             }
367             }
368              
369              
370             sub choose_a_file {
371 0 0   0 1   if ( ref $_[0] ne __PACKAGE__ ) {
372 0           my $ob = __PACKAGE__->new();
373 0           delete $ob->{backup_instance_defaults};
374 0           return $ob->choose_a_file( @_ );
375             }
376 0           my ( $self, $opt ) = @_;
377 0           $self->__prepare_opt( $opt );
378 0           my $init_dir = $self->__prepare_path();
379 0           my $curr_dir = $init_dir;
380 0           my $prompt_fmt = "$self->{file_type}-Directory: %s";
381 0           $prompt_fmt =~ s/^-//;
382 0 0         if ( length $self->{prompt_file_dir} ) {
383 0           $prompt_fmt .= "\n" . $self->{prompt_file_dir};
384             }
385              
386 0           CHOOSE_DIR: while ( 1 ) {
387 0           my $chosen_dir = $self->__choose_a_path( $init_dir, $prompt_fmt, '<<', 'OK' );
388 0 0         if ( ! defined $chosen_dir ) {
389 0           $self->__restore_defaults(); #
390 0           return;
391             }
392 0           my $chosen_file = $self->__a_file( $chosen_dir );
393 0 0         if ( ! defined $chosen_file ) {
394 0           next CHOOSE_DIR;
395             }
396 0           my $decoded = $self->{decoded};
397 0           $self->__restore_defaults();
398 0 0         return $decoded ? $chosen_file : encode( 'locale_fs', $chosen_file );
399             }
400             }
401              
402              
403             sub choose_a_directory {
404 0 0   0 1   if ( ref $_[0] ne __PACKAGE__ ) {
405 0           my $ob = __PACKAGE__->new();
406 0           delete $ob->{backup_instance_defaults};
407 0           return $ob->choose_a_directory( @_ );
408             }
409 0           my ( $self, $opt ) = @_;
410 0           $self->__prepare_opt( $opt );
411 0           my $init_dir = $self->__prepare_path();
412 0   0       my $prompt_fmt = ( $opt->{cs_label} // 'Directory: ' ) . "%s";
413 0 0         if ( length $self->{prompt} ) {
414 0           $prompt_fmt .= "\n" . $self->{prompt};
415             }
416 0           my $chosen_dir = $self->__choose_a_path( $init_dir, $prompt_fmt, $self->{back}, $self->{confirm} );
417 0           my $decoded = $self->{decoded};
418 0           $self->__restore_defaults();
419 0 0         if ( ! defined $chosen_dir ) {
420 0           return;
421             }
422 0 0         return $decoded ? $chosen_dir : encode( 'locale_fs', $chosen_dir );
423             }
424              
425              
426             sub __choose_a_path {
427 0     0     my ( $self, $dir, $prompt_fmt, $back, $confirm ) = @_;
428 0           my $prev_dir = $dir;
429              
430 0           while ( 1 ) {
431 0           my ( $dh, @dirs );
432 0           my $dir_fs = encode( 'locale_fs', $dir );
433 0 0         if ( ! eval {
434 0 0         opendir( $dh, $dir_fs ) or croak $!;
435 0           1 }
436             ) {
437 0           print "$@";
438             # Choose
439             choose(
440             [ 'Press Enter:' ],
441             { prompt => '', hide_cursor => $self->{hide_cursor}, mouse => $self->{mouse}, page => $self->{page},
442             footer => $self->{footer}, keep => $self->{keep}, margin => $self->{margin} }
443 0           );
444 0           $dir = dirname $dir;
445 0           next;
446             }
447 0           while ( my $file_fs = readdir $dh ) {
448 0 0         next if $file_fs =~ /^\.\.?\z/;
449 0 0 0       next if $file_fs =~ /^\./ && ! $self->{show_hidden};
450 0 0         if ( -d catdir $dir_fs, $file_fs ) {
451 0           push @dirs, decode( 'locale_fs', $file_fs );
452             }
453             }
454 0           closedir $dh;
455 0           my $parent_dir = $self->{parent_dir};
456 0           my @pre = ( undef, $confirm, $parent_dir );
457 0           my $prompt = sprintf $prompt_fmt, $prev_dir;
458             # Choose
459             my $choice = choose(
460             [ @pre, sort( @dirs ) ],
461             { info => $self->{info}, prompt => $prompt, alignment => $self->{alignment},
462             layout => $self->{layout}, order => $self->{order}, mouse => $self->{mouse},
463             clear_screen => $self->{clear_screen}, hide_cursor => $self->{hide_cursor}, margin => $self->{margin},
464             color => $self->{color}, tabs_info => $self->{tabs_info}, tabs_prompt => $self->{tabs_prompt},
465 0           page => $self->{page}, footer => $self->{footer}, keep => $self->{keep}, undef => $back }
466             );
467 0 0         if ( ! defined $choice ) {
    0          
    0          
468 0           return;
469             }
470             elsif ( $choice eq $confirm ) {
471 0           return $prev_dir;
472             }
473             elsif ( $choice eq $parent_dir ) {
474 0           $dir = dirname $dir;
475             }
476             else {
477 0           $dir = catdir $dir, $choice;
478             }
479 0           $prev_dir = $dir;
480             }
481             }
482              
483              
484             sub __a_file {
485 0     0     my ( $self, $dir ) = @_;
486 0           my $prev_dir = '';
487 0           my $chosen_file;
488              
489 0           while ( 1 ) {
490 0           my @files_fs;
491 0           my $dir_fs = encode( 'locale_fs', $dir );
492 0 0         if ( ! eval {
493 0 0         if ( $self->{filter} ) {
494 0           @files_fs = map { basename $_} grep { -e $_ } glob( encode( 'locale_fs', catfile $dir, $self->{filter} ) );
  0            
  0            
495             }
496             else {
497 0 0         opendir( my $dh, $dir_fs ) or croak $!;
498 0           @files_fs = readdir $dh;
499 0           closedir $dh;
500             }
501 0           1 }
502             ) {
503 0           print "$@";
504             # Choose
505             choose(
506             [ 'Press Enter:' ],
507             { prompt => '', hide_cursor => $self->{hide_cursor}, mouse => $self->{mouse}, page => $self->{page},
508             footer => $self->{footer}, keep => $self->{keep}, margin => $self->{margin} }
509 0           );
510 0           return;
511             }
512 0           my @files;
513 0           for my $file_fs ( @files_fs ) {
514 0 0         next if $file_fs =~ /^\.\.?\z/;
515 0 0 0       next if $file_fs =~ /^\./ && ! $self->{show_hidden};
516 0 0         next if -d catdir $dir_fs, $file_fs;
517 0           push @files, decode( 'locale_fs', $file_fs );
518             }
519 0           my $chosen_dir = "$self->{file_type}-Directory: $dir";
520 0           $chosen_dir =~ s/^-//;
521 0           my @tmp_prompt;
522 0           push @tmp_prompt, $chosen_dir;
523 0 0 0       push @tmp_prompt, ( $self->{cs_label} // $self->{file_type} . ': ' // 'File: ' ) . ( length $prev_dir ? $prev_dir : '' );
      0        
524 0 0         if ( length $self->{prompt} ) {
525 0           push @tmp_prompt, $self->{prompt};
526             }
527 0           my $prompt = join( "\n", @tmp_prompt );
528 0 0         if ( ! @files ) {
529 0           $prompt .= "\n";
530 0 0         if ( $self->{filter} ) {
531 0           $prompt .= 'No matches for filter "' . $self->{filter} . '".';
532             }
533             else {
534 0           $prompt .= 'No files.';
535             }
536             # Choose
537             choose(
538             [ ' < ' ],
539             { info => $self->{info}, prompt => $prompt, hide_cursor => $self->{hide_cursor},
540             mouse => $self->{mouse}, color => $self->{color}, page => $self->{page}, footer => $self->{footer},
541             keep => $self->{keep}, margin => $self->{margin} }
542 0           );
543 0           return;
544             }
545 0           my @pre = ( undef );
546 0 0         if ( $chosen_file ) {
547 0           push @pre, $self->{confirm};
548             }
549             # Choose
550             $chosen_file = choose(
551             [ @pre, sort( @files ) ],
552             { info => $self->{info}, prompt => $prompt, alignment => $self->{alignment}, layout => $self->{layout},
553             order => $self->{order}, mouse => $self->{mouse}, clear_screen => $self->{clear_screen},
554             hide_cursor => $self->{hide_cursor}, color => $self->{color}, tabs_info => $self->{tabs_info},
555             tabs_prompt => $self->{tabs_prompt}, page => $self->{page}, footer => $self->{footer},
556             keep => $self->{keep}, undef => $self->{back}, margin => $self->{margin} }
557 0           );
558 0 0         if ( ! length $chosen_file ) {
    0          
559 0 0         if ( length $prev_dir ) {
560 0           $prev_dir = '';
561 0           next;
562             }
563 0           return;
564             }
565             elsif ( $chosen_file eq $self->{confirm} ) {
566 0 0         return if ! length $prev_dir;
567 0           return catfile $dir, $prev_dir;
568             }
569             else {
570 0           $prev_dir = $chosen_file;
571             }
572             }
573             }
574              
575              
576             sub choose_a_number {
577 0 0   0 1   if ( ref $_[0] ne __PACKAGE__ ) {
578 0           my $ob = __PACKAGE__->new();
579 0           delete $ob->{backup_instance_defaults};
580 0           return $ob->choose_a_number( @_ );
581             }
582 0           my ( $self, $digits, $opt ) = @_;
583 0           my $default_digits = 7;
584 0 0         if ( ref $digits ) {
    0          
585 0           $opt = $digits;
586 0           $digits = $default_digits;
587             }
588             elsif ( ! $digits ) {
589 0           $digits = $default_digits;
590             }
591 0           $self->__prepare_opt( $opt );
592 0           my $tab = ' - ';
593 0           my $tab_w = print_columns( $tab );
594 0           my $sep_w = print_columns_ext( $self->{thousands_separator}, $self->{color} );
595 0           my $longest = $digits + int( ( $digits - 1 ) / 3 ) * $sep_w;
596 0           my @ranges = ();
597 0           for my $di ( 0 .. $digits - 1 ) {
598 0           my $begin = 1 . '0' x $di;
599 0 0         $begin = 0 if $di == 0;
600 0           $begin = insert_sep( $begin, $self->{thousands_separator} );
601 0           ( my $end = $begin ) =~ s/^[01]/9/;
602             unshift @ranges, unicode_sprintf( $begin, $longest, { right_justify => 1, color => $self->{color} } )
603             . $tab
604 0           . unicode_sprintf( $end, $longest, { right_justify => 1, color => $self->{color} } );
605             }
606 0           my $back_tmp = unicode_sprintf( $self->{back}, $longest * 2 + $tab_w + 1, { color => $self->{color} } );
607 0           my $confirm_tmp = unicode_sprintf( $self->{confirm}, $longest * 2 + $tab_w + 1, { color => $self->{color} } );
608 0 0         if ( print_columns_ext( $ranges[0], $self->{color} ) > get_term_width() ) {
609 0           @ranges = ();
610 0           for my $di ( 0 .. $digits - 1 ) {
611 0           my $begin = 1 . '0' x $di;
612 0 0         $begin = 0 if $di == 0;
613 0           $begin = insert_sep( $begin, $self->{thousands_separator} );
614 0           unshift @ranges, unicode_sprintf( $begin, $longest, { color => $self->{color} } );
615             }
616 0           $confirm_tmp = $self->{confirm};
617 0           $back_tmp = $self->{back};
618             }
619 0           my %numbers;
620             my $result;
621 0 0 0       if ( defined $self->{default_number} && length $self->{default_number} <= $digits ) {
622 0           my $count_zeros = 0;
623 0           for my $d ( reverse split '', $self->{default_number} ) {
624 0           $numbers{$count_zeros} = $d * 10 ** $count_zeros;
625 0           $count_zeros++;
626             }
627 0           $result = sum( @numbers{keys %numbers} );
628 0           $result = insert_sep( $result, $self->{thousands_separator} );
629             }
630              
631 0           NUMBER: while ( 1 ) {
632 0           my $cs_row;
633 0 0 0       if ( defined $self->{cs_label} || length $result ) {
634 0 0         my $tmp_result = length $result ? $result : '';
635 0 0         my $tmp_cs_label = defined $self->{cs_label} ? $self->{cs_label} : '';
636 0           $cs_row = sprintf( "%s%*s", $tmp_cs_label, $longest, $tmp_result );
637 0 0         if ( print_columns( $cs_row ) > get_term_width() ) {
638 0           $cs_row = $tmp_result;
639             }
640             }
641 0           my @tmp_prompt;
642 0 0         if ( defined $cs_row ) {
643 0           push @tmp_prompt, $cs_row;
644             }
645 0 0         if ( length $self->{prompt} ) {
646 0           push @tmp_prompt, $self->{prompt};
647             }
648 0           my $prompt = join "\n", @tmp_prompt;
649 0           my @pre = ( undef, $confirm_tmp ); # confirm if $result ?
650             # Choose
651             my $range = choose(
652             $self->{small_first} ? [ @pre, reverse @ranges ] : [ @pre, @ranges ],
653             { info => $self->{info}, prompt => $prompt, layout => 2, alignment => 1, mouse => $self->{mouse},
654             clear_screen => $self->{clear_screen}, hide_cursor => $self->{hide_cursor}, color => $self->{color},
655             tabs_info => $self->{tabs_info}, tabs_prompt => $self->{tabs_prompt}, page => $self->{page},
656             footer => $self->{footer}, keep => $self->{keep}, undef => $back_tmp, margin => $self->{margin} }
657 0 0         );
658 0 0         if ( ! defined $range ) {
659 0 0         if ( defined $result ) {
660 0           $result = undef;
661 0           %numbers = ();
662 0           next NUMBER;
663             }
664             else {
665 0           $self->__restore_defaults();
666 0           return;
667             }
668             }
669 0 0         if ( $range eq $confirm_tmp ) {
670 0           $result = _remove_thousands_separators( $result, $self->{thousands_separator} );
671 0           $self->__restore_defaults();
672 0           return $result;
673             }
674 0           my $zeros = ( split /\s*-\s*/, $range )[0];
675 0           $zeros =~ s/^\s*\d//;
676 0           my $zeros_no_sep = _remove_thousands_separators( $zeros, $self->{thousands_separator} );
677 0           my $count_zeros = length $zeros_no_sep;
678 0 0         my @choices = $count_zeros ? map( $_ . $zeros, 1 .. 9 ) : ( 0 .. 9 );
679             # Choose
680             my $number = choose(
681             [ undef, @choices, $self->{reset} ],
682             { info => $self->{info}, prompt => $prompt, layout => 1, alignment => 2, order => 0,
683             mouse => $self->{mouse}, clear_screen => $self->{clear_screen}, hide_cursor => $self->{hide_cursor},
684             color => $self->{color}, tabs_info => $self->{tabs_info}, tabs_prompt => $self->{tabs_prompt},
685             page => $self->{page}, footer => $self->{footer}, keep => $self->{keep}, undef => '<<',
686             margin => $self->{margin} }
687 0           );
688 0 0         next if ! defined $number;
689 0 0         if ( $number eq $self->{reset} ) {
690 0           delete $numbers{$count_zeros};
691             }
692             else {
693 0           $numbers{$count_zeros} = _remove_thousands_separators( $number, $self->{thousands_separator} );
694             }
695 0           $result = sum( @numbers{keys %numbers} );
696 0           $result = insert_sep( $result, $self->{thousands_separator} );
697             }
698             }
699              
700              
701             sub _remove_thousands_separators {
702 0     0     my ( $str, $sep ) = @_;
703             # https://stackoverflow.com/questions/13119241/substitution-with-empty-string-unexpected-result
704 0 0 0       if ( defined $str && $sep ne '' ) {
705 0           $str =~ s/\Q$sep\E//g;
706             }
707 0           return $str;
708             }
709              
710              
711             sub choose_a_subset {
712 0 0   0 1   if ( ref $_[0] ne __PACKAGE__ ) {
713 0           my $ob = __PACKAGE__->new();
714 0           delete $ob->{backup_instance_defaults};
715 0           return $ob->choose_a_subset( @_ );
716             }
717 0           my ( $self, $available, $opt ) = @_;
718             #my $subseq_tab = length( $opt->{cs_label} // '.' ) ? 2 : 0; # width a default cs_label set
719 0 0         my $subseq_tab = length $opt->{cs_label} ? 2 : 0;
720 0           $self->__prepare_opt( $opt, $subseq_tab );
721 0           my $new_idx = [];
722 0           my $curr_avail = [ @$available ];
723 0           my $bu = [];
724 0           my @pre = ( undef, $self->{confirm} );
725              
726 0           while ( 1 ) {
727 0           my @tmp_prompt;
728             my $cs;
729 0 0         if ( defined $self->{cs_label} ) {
730 0           $cs .= $self->{cs_label};
731             }
732 0 0         if ( @$new_idx ) {
    0          
733 0 0         $cs .= $self->{cs_begin} . join( $self->{cs_separator}, map { defined $_ ? $_ : '' } @{$available}[@$new_idx] ) . $self->{cs_end};
  0            
  0            
734             }
735             elsif ( $opt->{all_by_default} ) {
736 0           $cs .= $self->{cs_begin} . '*' . $self->{cs_end};
737             }
738 0 0         if ( defined $cs ) {
739 0           @tmp_prompt = ( $cs );
740             }
741 0 0         if ( length $self->{prompt} ) {
742 0           push @tmp_prompt, $self->{prompt};
743             }
744 0           my $mark;
745 0 0 0       if ( defined $self->{mark} && @{$self->{mark}} ) {
  0            
746 0           $mark = [ map { $_ + @pre } @{$self->{mark}} ];
  0            
  0            
747             }
748 0           my $meta_items = [ 0 .. $#pre ];
749 0           my $prompt = join "\n", @tmp_prompt;
750             # Choose
751             my @idx = choose(
752 0 0         [ @pre, length( $self->{prefix} ) ? map { $self->{prefix} . ( defined $_ ? $_ : '' ) } @$curr_avail : @$curr_avail ],
753             { info => $self->{info}, prompt => $prompt, layout => $self->{layout}, index => 1,
754             alignment => $self->{alignment}, order => $self->{order}, mouse => $self->{mouse},
755             meta_items => $meta_items, mark => $mark, include_highlighted => 2,
756             clear_screen => $self->{clear_screen}, hide_cursor => $self->{hide_cursor},
757             color => $self->{color}, tabs_info => $self->{tabs_info}, tabs_prompt => $self->{tabs_prompt},
758             page => $self->{page}, footer => $self->{footer}, keep => $self->{keep}, undef => $self->{back},
759             busy_string => $self->{busy_string}, margin => $self->{margin} }
760 0 0         );
761 0           $self->{mark} = $mark = undef;
762 0 0 0       if ( ! defined $idx[0] || $idx[0] == 0 ) {
763 0 0         if ( @$bu ) {
764 0           ( $curr_avail, $new_idx ) = @{pop @$bu};
  0            
765 0           next;
766             }
767 0           $self->__restore_defaults();
768 0           return;
769             }
770 0           push @$bu, [ [ @$curr_avail ], [ @$new_idx ] ];
771 0           my $ok;
772 0 0         if ( $idx[0] == $#pre ) {
773 0           $ok = shift @idx;
774             }
775 0           my @tmp_idx;
776 0           for my $i ( reverse @idx ) {
777 0           $i -= @pre;
778 0 0         if ( ! $self->{keep_chosen} ) {
779 0           splice( @$curr_avail, $i, 1 );
780 0           for my $used_i ( sort { $a <=> $b } @$new_idx ) {
  0            
781 0 0         last if $used_i > $i;
782 0           ++$i;
783             }
784             }
785 0           push @tmp_idx, $i;
786             }
787 0           push @$new_idx, reverse @tmp_idx;
788 0 0         if ( $ok ) {
789 0 0 0       if ( ! @$new_idx && $opt->{all_by_default} ) {
790 0           $new_idx = [ 0 .. $#{$available} ];
  0            
791             }
792 0           my $return_indexes = $self->{index}; # because __restore_defaults resets $self->{index}
793 0           $self->__restore_defaults();
794 0 0         return $return_indexes ? $new_idx : [ @{$available}[@$new_idx] ];
  0            
795             }
796             }
797             }
798              
799              
800             sub settings_menu {
801 0 0   0 1   if ( ref $_[0] ne __PACKAGE__ ) {
802 0           my $ob = __PACKAGE__->new();
803 0           delete $ob->{backup_instance_defaults};
804 0           return $ob->settings_menu( @_ );
805             }
806 0           my ( $self, $menu, $curr, $opt ) = @_;
807 0           $self->__prepare_opt( $opt );
808 0           my $longest = 0;
809 0           my $new = {};
810 0           my $name_w = {};
811 0           for my $sub ( @$menu ) {
812 0           my ( $key, $name, $values ) = @$sub;
813 0           $name_w->{$key} = print_columns_ext( $name, $self->{color} );
814 0 0         if ( $name_w->{$key} > $longest ) {
815 0           $longest = $name_w->{$key};
816             }
817 0 0         $curr->{$key} = 0 if ! defined $curr->{$key};
818 0 0         $curr->{$key} = 0 if ! defined $values->[$curr->{$key}];
819 0           $new->{$key} = $curr->{$key};
820             }
821 0           my @print_keys;
822 0           for my $sub ( @$menu ) {
823 0           my ( $key, $name, $values ) = @$sub;
824 0           my $current = $values->[$new->{$key}];
825 0           push @print_keys, $name . ( ' ' x ( $longest - $name_w->{$key} ) ) . " [$current]";
826             }
827 0           my @pre = ( undef, $self->{confirm} );
828 0           $ENV{TC_RESET_AUTO_UP} = 0;
829 0           my $default = 0;
830 0           my $count = 0;
831              
832 0           while ( 1 ) {
833 0           my @tmp_prompt;
834 0 0         if ( defined $self->{cs_label} ) {
835 0           push @tmp_prompt, $self->{cs_label} . $self->{cs_begin} . join( $self->{cs_separator}, map { "$_=$new->{$_}" } keys %$new ) . $self->{cs_end};
  0            
836             }
837 0 0         if ( length $self->{prompt} ) {
838 0           push @tmp_prompt, $self->{prompt};
839             }
840 0           my $prompt = join( "\n", @tmp_prompt );
841             # Choose
842             my $idx = choose(
843             [ @pre, @print_keys ],
844             { info => $self->{info}, prompt => $prompt, index => 1, default => $default, layout => 2, alignment => 0,
845             mouse => $self->{mouse}, clear_screen => $self->{clear_screen}, hide_cursor => $self->{hide_cursor},
846             color => $self->{color}, tabs_info => $self->{tabs_info}, tabs_prompt => $self->{tabs_prompt},
847             page => $self->{page}, footer => $self->{footer}, keep => $self->{keep}, undef => $self->{back},
848             margin => $self->{margin} }
849 0           );
850 0 0         if ( ! $idx ) {
    0          
851 0           $self->__restore_defaults();
852 0           return;
853             }
854             elsif ( $idx == $#pre ) {
855 0           my $change = 0;
856 0           for my $sub ( @$menu ) {
857 0           my $key = $sub->[0];
858 0 0         if ( $curr->{$key} == $new->{$key} ) {
859 0           next;
860             }
861 0           $curr->{$key} = $new->{$key};
862 0           $change++;
863             }
864 0           $self->__restore_defaults();
865 0           return $change; #
866             }
867 0           my $i = $idx - @pre;
868 0           my $key = $menu->[$i][0];
869 0           my $values = $menu->[$i][2];
870 0 0         if ( $default == $idx ) {
871 0 0         if ( $ENV{TC_RESET_AUTO_UP} ) {
    0          
872 0           $count = 0;
873             }
874             elsif ( $count == @$values ) {
875 0           $default = 0;
876 0           $count = 0;
877 0           next;
878             }
879             }
880             else {
881 0           $count = 0;
882 0           $default = $idx;
883             }
884 0           ++$count;
885 0           my $curr_value = $values->[$new->{$key}];
886 0           $new->{$key}++;
887 0 0         if ( $new->{$key} == @$values ) {
888 0           $new->{$key} = 0;
889             }
890 0           my $new_value = $values->[$new->{$key}];
891 0           $print_keys[$i] =~ s/ \[ \Q$curr_value\E \] \z /[$new_value]/x;
892             }
893             }
894              
895              
896              
897             sub insert_sep {
898 0     0 0   my ( $number, $separator ) = @_;
899 0 0         return if ! defined $number;
900 0 0         return $number if ! length $number;
901 0 0         $separator = ',' if ! defined $separator;
902 0 0         return $number if $separator eq '';
903 0 0         return $number if $number =~ /\Q$separator\E/;
904 0           $number =~ s/(^[-+]?\d+?(?=(?>(?:\d{3})+)(?!\d))|\G\d{3}(?=\d))/$1$separator/g;
905             # http://perldoc.perl.org/perlfaq5.html#How-can-I-output-my-numbers-with-commas-added?
906 0           return $number;
907             }
908              
909              
910             sub get_term_size {
911 0     0 0   require Term::Choose::Screen;
912 0           return Term::Choose::Screen::get_term_size();
913             }
914              
915              
916             sub get_term_width {
917 0     0 0   require Term::Choose::Screen;
918 0           my $term_width = ( Term::Choose::Screen::get_term_size() )[0];
919 0           return $term_width;
920             }
921              
922             sub get_term_height {
923 0     0 0   require Term::Choose::Screen;
924 0           my $term_height = ( Term::Choose::Screen::get_term_size() )[1];
925 0           return $term_height;
926             }
927              
928              
929             sub unicode_sprintf {
930 0     0 0   my ( $str, $avail_w, $opt ) = @_;
931 0   0       $opt ||= {};
932 0           my $colwidth;
933 0 0         if ( $opt->{color} ) {
934 0           ( my $tmp = $str ) =~ s/\e\[[\d;]*m//g;
935 0           $colwidth = print_columns( $tmp );
936             }
937             else {
938 0           $colwidth = print_columns( $str );
939             }
940             #my $colwidth = print_columns_ext( $str, $opt->{color} );
941 0 0         if ( $colwidth > $avail_w ) {
    0          
942 0 0         if ( @{$opt->{mark_if_truncated}||[]} ) {
  0 0          
943 0           return cut_to_printwidth( $str, $avail_w - $opt->{mark_if_truncated}[1] ) . $opt->{mark_if_truncated}[0];
944             }
945 0           return cut_to_printwidth( $str, $avail_w );
946             }
947             elsif ( $colwidth < $avail_w ) {
948 0 0         if ( $opt->{right_justify} ) {
949 0           return " " x ( $avail_w - $colwidth ) . $str;
950             }
951             else {
952 0           return $str . " " x ( $avail_w - $colwidth );
953             }
954             }
955             else {
956 0           return $str;
957             }
958             }
959              
960              
961             sub print_columns_ext {
962 0     0 0   my ( $str, $color ) = @_;
963 0 0         if ( $color ) {
964 0           $str =~ s/\e\[[\d;]*m//g;
965             }
966 0           return print_columns( $str );
967             }
968              
969              
970              
971              
972             1;
973              
974             __END__