use
5.10.1;
our
$VERSION
=
'0.145'
;
our
@EXPORT_OK
=
qw( choose_a_directory choose_a_file choose_directories choose_a_number choose_a_subset settings_menu
insert_sep get_term_size get_term_width get_term_height unicode_sprintf )
;
use
Encode
qw( decode encode )
;
sub
new {
my
$class
=
shift
;
my
(
$opt
) =
@_
;
my
$instance_defaults
= _defaults();
if
(
defined
$opt
) {
croak
"Options have to be passed as a HASH reference."
if
ref
$opt
ne
'HASH'
;
my
$caller
=
'new'
;
validate_options( _valid_options(
$caller
),
$opt
,
$caller
);
for
my
$key
(
keys
%$opt
) {
$instance_defaults
->{
$key
} =
$opt
->{
$key
}
if
defined
$opt
->{
$key
};
}
}
my
$self
=
bless
$instance_defaults
,
$class
;
$self
->{backup_instance_defaults} = {
%$instance_defaults
};
return
$self
;
}
sub
__restore_defaults {
my
(
$self
) =
@_
;
if
(
exists
$self
->{backup_instance_defaults} ) {
my
$instance_defaults
=
$self
->{backup_instance_defaults};
for
my
$key
(
keys
%$self
) {
if
(
$key
eq
'backup_instance_defaults'
) {
next
;
}
elsif
(
exists
$instance_defaults
->{
$key
} ) {
$self
->{
$key
} =
$instance_defaults
->{
$key
};
}
else
{
delete
$self
->{
$key
};
}
}
}
}
sub
__prepare_opt {
my
(
$self
,
$opt
,
$subseq_tab
) =
@_
;
if
( !
defined
$opt
) {
$opt
= {};
}
croak
"Options have to be passed as a HASH reference."
if
ref
$opt
ne
'HASH'
;
if
(
%$opt
) {
my
$caller
= (
caller
( 1 ) )[3];
$caller
=~ s/^.+::(?:__)?([^:]+)\z/$1/;
validate_options( _valid_options(
$caller
),
$opt
,
$caller
);
my
$defaults
= _defaults();
for
my
$key
(
keys
%$opt
) {
if
( !
defined
$opt
->{
$key
} &&
defined
$defaults
->{
$key
} ) {
$self
->{
$key
} =
$defaults
->{
$key
};
}
else
{
$self
->{
$key
} =
$opt
->{
$key
};
}
}
}
if
( !
defined
$self
->{tabs_info} ) {
if
(
defined
$self
->{margin} ) {
$self
->{tabs_info} = [
$self
->{margin}[3] // 0,
$self
->{margin}[3] // 0,
$self
->{margin}[1] // 0 ];
}
}
if
( !
defined
$self
->{tabs_prompt} ) {
if
(
defined
$self
->{margin} ) {
$self
->{tabs_prompt} = [
$self
->{margin}[3] // 0,
(
$self
->{margin}[3] // 0 ) + (
$subseq_tab
// 0 ),
$self
->{margin}[1] // 0
];
}
elsif
(
$subseq_tab
) {
$self
->{tabs_prompt} = [ 0,
$subseq_tab
, 0 ];
}
}
}
sub
_valid_options {
my
(
$caller
) =
@_
;
my
%valid
= (
all_by_default
=>
'[ 0 1 ]'
,
clear_screen
=>
'[ 0 1 ]'
,
decoded
=>
'[ 0 1 ]'
,
hide_cursor
=>
'[ 0 1 ]'
,
index
=>
'[ 0 1 ]'
,
keep_chosen
=>
'[ 0 1 ]'
,
mouse
=>
'[ 0 1 ]'
,
order
=>
'[ 0 1 ]'
,
show_hidden
=>
'[ 0 1 ]'
,
small_first
=>
'[ 0 1 ]'
,
alignment
=>
'[ 0 1 2 ]'
,
color
=>
'[ 0 1 2 ]'
,
layout
=>
'[ 0 1 2 ]'
,
page
=>
'[ 0 1 2 ]'
,
keep
=>
'[ 1-9 ][ 0-9 ]*'
,
default_number
=>
'[ 0-9 ]+'
,
margin
=>
'Array_Int'
,
mark
=>
'Array_Int'
,
tabs_info
=>
'Array_Int'
,
tabs_prompt
=>
'Array_Int'
,
busy_string
=>
'Str'
,
info
=>
'Str'
,
init_dir
=>
'Str'
,
back
=>
'Str'
,
filter
=>
'Str'
,
footer
=>
'Str'
,
confirm
=>
'Str'
,
prefix
=>
'Str'
,
prompt
=>
'Str'
,
prompt2
=>
'Str'
,
cs_begin
=>
'Str'
,
cs_end
=>
'Str'
,
cs_label
=>
'Str'
,
cs_separator
=>
'Str'
,
thousands_separator
=>
'Str'
,
);
my
$options
;
if
(
$caller
eq
'new'
) {
$options
= [
keys
%valid
];
}
else
{
$options
= _routine_options(
$caller
);
}
return
{
map
{
$_
=>
$valid
{
$_
} }
@$options
};
};
sub
_defaults {
return
{
alignment
=> 0,
all_by_default
=> 0,
back
=>
'BACK'
,
clear_screen
=> 0,
color
=> 0,
confirm
=>
'CONFIRM'
,
cs_begin
=>
''
,
cs_end
=>
''
,
cs_separator
=>
', '
,
decoded
=> 1,
hide_cursor
=> 1,
index
=> 0,
keep_chosen
=> 0,
layout
=> 1,
mouse
=> 0,
order
=> 1,
parent_dir
=>
'..'
,
prefix
=>
''
,
prompt
=>
'Your choice: '
,
show_hidden
=> 1,
small_first
=> 0,
thousands_separator
=>
','
,
reset
=>
'reset'
,
};
};
sub
_routine_options {
my
(
$caller
) =
@_
;
my
@every
= (
qw( back clear_screen color confirm cs_label footer hide_cursor info keep margin mouse page prompt tabs_info tabs_prompt )
);
my
$options
;
if
(
$caller
eq
'choose_directories'
) {
$options
= [
@every
,
qw( init_dir layout order alignment show_hidden decoded prompt2 )
];
}
elsif
(
$caller
eq
'choose_a_directory'
) {
$options
= [
@every
,
qw( init_dir layout order alignment show_hidden decoded )
];
}
elsif
(
$caller
eq
'choose_a_file'
) {
$options
= [
@every
,
qw( init_dir layout order alignment show_hidden decoded filter prompt2 )
];
}
elsif
(
$caller
eq
'choose_a_number'
) {
$options
= [
@every
,
qw( small_first reset thousands_separator default_number )
];
}
elsif
(
$caller
eq
'choose_a_subset'
) {
$options
= [
@every
,
qw( layout order alignment keep_chosen index prefix all_by_default cs_begin cs_end cs_separator mark busy_string )
];
}
elsif
(
$caller
eq
'settings_menu'
) {
$options
= [
@every
,
qw( cs_begin cs_end cs_separator )
];
}
return
$options
;
}
sub
__prepare_path {
my
(
$self
) =
@_
;
my
$init_dir_fs
;
if
(
defined
$self
->{init_dir} ) {
$init_dir_fs
= encode(
'locale_fs'
,
$self
->{init_dir} );
if
( ! -d
$init_dir_fs
) {
my
$prompt
=
'Could not find the directory "'
;
$prompt
.= decode
'locale_fs'
,
$init_dir_fs
;
$prompt
.=
'". Falling back to the home directory.'
;
choose(
[
'Press ENTER to continue'
],
{
prompt
=>
$prompt
,
hide_cursor
=>
$self
->{hide_cursor},
mouse
=>
$self
->{mouse},
page
=>
$self
->{page},
footer
=>
$self
->{footer},
keep
=>
$self
->{keep} }
);
$init_dir_fs
= File::HomeDir->my_home();
}
}
else
{
$init_dir_fs
= File::HomeDir->my_home();
}
if
( ! -d
$init_dir_fs
) {
croak
"Could not find the home directory."
;
}
my
$dir_fs
= realpath
$init_dir_fs
;
my
$dir
= decode(
'locale_fs'
,
$dir_fs
);
return
$dir
;
}
sub
__available_dirs {
my
(
$self
,
$dir
) =
@_
;
my
$dir_fs
= encode(
'locale_fs'
,
$dir
);
my
$dh
;
if
( !
eval
{
opendir
(
$dh
,
$dir_fs
) or croak $!;
1 }
) {
print
"$@"
;
choose(
[
'Press Enter:'
],
{
prompt
=>
''
,
hide_cursor
=>
$self
->{hide_cursor},
mouse
=>
$self
->{mouse},
page
=>
$self
->{page},
footer
=>
$self
->{footer},
keep
=>
$self
->{keep},
margin
=>
$self
->{margin} }
);
return
;
}
my
@dirs
;
while
(
my
$file_fs
=
readdir
$dh
) {
next
if
$file_fs
=~ /^\.\.?\z/;
next
if
$file_fs
=~ /^\./ && !
$self
->{show_hidden};
if
( -d catdir
$dir_fs
,
$file_fs
) {
push
@dirs
, decode(
'locale_fs'
,
$file_fs
);
}
}
closedir
$dh
;
return
[
sort
@dirs
];
}
sub
choose_directories {
if
(
ref
$_
[0] ne __PACKAGE__ ) {
my
$ob
= __PACKAGE__->new();
delete
$ob
->{backup_instance_defaults};
return
$ob
->choose_directories(
@_
);
}
my
(
$self
,
$opt
) =
@_
;
my
$subseq_tab
= 2;
$self
->__prepare_opt(
$opt
,
$subseq_tab
);
my
$dir
=
$self
->__prepare_path();
my
$chosen_dirs
= [];
my
(
$confirm
,
$change_path
,
$add_dirs
) = (
$self
->{confirm},
'- Change Location'
,
'- Add Directories'
);
my
@bu
;
CHOOSE_MODE:
while
( 1 ) {
my
$key_dirs
=
$self
->{cs_label} //
'Chosen Dirs: '
;
my
$dirs_chosen
=
$key_dirs
. (
@$chosen_dirs
?
join
(
', '
,
@$chosen_dirs
) :
'---'
);
my
$key_path
=
'Location: '
;
my
$path
=
$key_path
.
$dir
;
my
$prompt
=
$dirs_chosen
.
"\n"
.
$path
;
my
$choice
= choose(
[
undef
,
$confirm
,
$change_path
,
$add_dirs
],
{
info
=>
$self
->{info},
prompt
=>
$prompt
,
layout
=> 2,
mouse
=>
$self
->{mouse},
margin
=>
$self
->{margin},
clear_screen
=>
$self
->{clear_screen},
hide_cursor
=>
$self
->{hide_cursor},
page
=>
$self
->{page},
footer
=>
$self
->{footer},
keep
=>
$self
->{keep},
undef
=>
$self
->{back},
color
=>
$self
->{color},
tabs_info
=>
$self
->{tabs_info},
tabs_prompt
=>
$self
->{tabs_prompt} }
);
if
( !
defined
$choice
) {
if
(
@bu
) {
(
$dir
,
$chosen_dirs
) = @{
pop
@bu
};
next
CHOOSE_MODE;
}
$self
->__restore_defaults();
return
;
}
elsif
(
$choice
eq
$confirm
) {
my
$decoded
=
$self
->{decoded};
$self
->__restore_defaults();
return
$decoded
?
$chosen_dirs
: [
map
{ encode
'locale_fs'
,
$_
}
@$chosen_dirs
];
}
elsif
(
$choice
eq
$change_path
) {
my
$prompt_fmt
=
$key_path
.
"%s"
;
if
(
length
$self
->{prompt} ) {
$prompt_fmt
.=
"\n"
.
$self
->{prompt};
}
my
$tmp_dir
=
$self
->__choose_a_path(
$dir
,
$prompt_fmt
,
'<<'
,
'OK'
);
if
(
defined
$tmp_dir
) {
$dir
=
$tmp_dir
;
}
}
elsif
(
$choice
eq
$add_dirs
) {
my
$avail_dirs
=
$self
->__available_dirs(
$dir
);
if
( !
defined
$avail_dirs
) {
next
CHOOSE_MODE;
}
my
%bu_opt
;
my
$options
= _routine_options(
'choose_directories'
);
for
my
$o
(
@$options
) {
$bu_opt
{
$o
} =
$self
->{
$o
};
}
my
$cs_label
=
$dirs_chosen
.
"\n"
.
$path
.
"\n"
.
'Add: '
;
my
$prompt
=
$self
->{prompt2} //
$self
->{prompt};
my
$idxs
=
$self
->choose_a_subset(
[
sort
@$avail_dirs
],
{
cs_label
=>
$cs_label
,
back
=>
'<<'
,
confirm
=>
'OK'
,
cs_begin
=>
undef
,
index
=> 1,
keep_chosen
=> 1,
prompt
=>
$prompt
,
}
);
for
my
$o
(
keys
%bu_opt
) {
$self
->{
$o
} =
$bu_opt
{
$o
};
}
if
(
defined
$idxs
&&
@$idxs
) {
push
@bu
, [
$dir
, [
@$chosen_dirs
] ];
push
@$chosen_dirs
,
map
{ catdir
$dir
,
$_
} @{
$avail_dirs
}[
@$idxs
];
}
}
}
}
sub
choose_a_file {
if
(
ref
$_
[0] ne __PACKAGE__ ) {
my
$ob
= __PACKAGE__->new();
delete
$ob
->{backup_instance_defaults};
return
$ob
->choose_a_file(
@_
);
}
my
(
$self
,
$opt
) =
@_
;
$self
->__prepare_opt(
$opt
);
my
$init_dir
=
$self
->__prepare_path();
my
$prompt_fmt
=
"File Directory: %s"
;
if
(
length
$self
->{prompt} ) {
$prompt_fmt
.=
"\n"
.
$self
->{prompt};
}
CHOOSE_DIR:
while
( 1 ) {
my
$chosen_dir
=
$self
->__choose_a_path(
$init_dir
,
$prompt_fmt
,
'<<'
,
'OK'
);
if
( !
defined
$chosen_dir
) {
$self
->__restore_defaults();
return
;
}
my
$chosen_file
=
$self
->__a_file(
$chosen_dir
);
if
( !
defined
$chosen_file
) {
next
CHOOSE_DIR;
}
my
$decoded
=
$self
->{decoded};
$self
->__restore_defaults();
return
$decoded
?
$chosen_file
: encode(
'locale_fs'
,
$chosen_file
);
}
}
sub
choose_a_directory {
if
(
ref
$_
[0] ne __PACKAGE__ ) {
my
$ob
= __PACKAGE__->new();
delete
$ob
->{backup_instance_defaults};
return
$ob
->choose_a_directory(
@_
);
}
my
(
$self
,
$opt
) =
@_
;
$self
->__prepare_opt(
$opt
);
my
$init_dir
=
$self
->__prepare_path();
my
$prompt_fmt
= (
$opt
->{cs_label} //
'Directory: '
) .
"%s"
;
if
(
length
$self
->{prompt} ) {
$prompt_fmt
.=
"\n"
.
$self
->{prompt};
}
my
$chosen_dir
=
$self
->__choose_a_path(
$init_dir
,
$prompt_fmt
,
$self
->{back},
$self
->{confirm} );
my
$decoded
=
$self
->{decoded};
$self
->__restore_defaults();
if
( !
defined
$chosen_dir
) {
return
;
}
return
$decoded
?
$chosen_dir
: encode(
'locale_fs'
,
$chosen_dir
);
}
sub
__choose_a_path {
my
(
$self
,
$dir
,
$prompt_fmt
,
$back
,
$confirm
) =
@_
;
my
$prev_dir
=
$dir
;
while
( 1 ) {
my
(
$dh
,
@dirs
);
my
$dir_fs
= encode(
'locale_fs'
,
$dir
);
if
( !
eval
{
opendir
(
$dh
,
$dir_fs
) or croak $!;
1 }
) {
print
"$@"
;
choose(
[
'Press Enter:'
],
{
prompt
=>
''
,
hide_cursor
=>
$self
->{hide_cursor},
mouse
=>
$self
->{mouse},
page
=>
$self
->{page},
footer
=>
$self
->{footer},
keep
=>
$self
->{keep},
margin
=>
$self
->{margin} }
);
$dir
= dirname
$dir
;
next
;
}
while
(
my
$file_fs
=
readdir
$dh
) {
next
if
$file_fs
=~ /^\.\.?\z/;
next
if
$file_fs
=~ /^\./ && !
$self
->{show_hidden};
if
( -d catdir
$dir_fs
,
$file_fs
) {
push
@dirs
, decode(
'locale_fs'
,
$file_fs
);
}
}
closedir
$dh
;
my
$parent_dir
=
$self
->{parent_dir};
my
@pre
= (
undef
,
$confirm
,
$parent_dir
);
my
$prompt
=
sprintf
$prompt_fmt
,
$prev_dir
;
my
$choice
= choose(
[
@pre
,
sort
(
@dirs
) ],
{
info
=>
$self
->{info},
prompt
=>
$prompt
,
alignment
=>
$self
->{alignment},
layout
=>
$self
->{layout},
order
=>
$self
->{order},
mouse
=>
$self
->{mouse},
clear_screen
=>
$self
->{clear_screen},
hide_cursor
=>
$self
->{hide_cursor},
margin
=>
$self
->{margin},
color
=>
$self
->{color},
tabs_info
=>
$self
->{tabs_info},
tabs_prompt
=>
$self
->{tabs_prompt},
page
=>
$self
->{page},
footer
=>
$self
->{footer},
keep
=>
$self
->{keep},
undef
=>
$back
}
);
if
( !
defined
$choice
) {
return
;
}
elsif
(
$choice
eq
$confirm
) {
return
$prev_dir
;
}
elsif
(
$choice
eq
$parent_dir
) {
$dir
= dirname
$dir
;
}
else
{
$dir
= catdir
$dir
,
$choice
;
}
$prev_dir
=
$dir
;
}
}
sub
__a_file {
my
(
$self
,
$dir
) =
@_
;
my
$prev_dir
=
''
;
my
$chosen_file
;
while
( 1 ) {
my
@files_fs
;
my
$dir_fs
= encode(
'locale_fs'
,
$dir
);
if
( !
eval
{
if
(
$self
->{filter} ) {
@files_fs
=
map
{ basename
$_
}
grep
{ -e
$_
}
glob
( encode(
'locale_fs'
, catfile
$dir
,
$self
->{filter} ) );
}
else
{
opendir
(
my
$dh
,
$dir_fs
) or croak $!;
@files_fs
=
readdir
$dh
;
closedir
$dh
;
}
1 }
) {
print
"$@"
;
choose(
[
'Press Enter:'
],
{
prompt
=>
''
,
hide_cursor
=>
$self
->{hide_cursor},
mouse
=>
$self
->{mouse},
page
=>
$self
->{page},
footer
=>
$self
->{footer},
keep
=>
$self
->{keep},
margin
=>
$self
->{margin} }
);
return
;
}
my
@files
;
for
my
$file_fs
(
@files_fs
) {
next
if
$file_fs
=~ /^\.\.?\z/;
next
if
$file_fs
=~ /^\./ && !
$self
->{show_hidden};
next
if
-d catdir
$dir_fs
,
$file_fs
;
push
@files
, decode(
'locale_fs'
,
$file_fs
);
}
my
$chosen_dir
=
"Directory: $dir"
;
my
@tmp_prompt
;
push
@tmp_prompt
,
$chosen_dir
;
push
@tmp_prompt
, (
$self
->{cs_label} //
'File: '
) . (
length
$prev_dir
?
$prev_dir
:
''
);
my
$prompt2
=
$self
->{prompt2} //
$self
->{prompt};
if
(
length
$prompt2
) {
push
@tmp_prompt
,
$prompt2
;
}
my
$prompt
=
join
(
"\n"
,
@tmp_prompt
);
if
( !
@files
) {
$prompt
.=
"\n"
;
if
(
$self
->{filter} ) {
$prompt
.=
'No matches for filter "'
.
$self
->{filter} .
'".'
;
}
else
{
$prompt
.=
'No files.'
;
}
choose(
[
' < '
],
{
info
=>
$self
->{info},
prompt
=>
$prompt
,
hide_cursor
=>
$self
->{hide_cursor},
mouse
=>
$self
->{mouse},
color
=>
$self
->{color},
page
=>
$self
->{page},
footer
=>
$self
->{footer},
keep
=>
$self
->{keep},
margin
=>
$self
->{margin} }
);
return
;
}
my
@pre
= (
undef
);
if
(
$chosen_file
) {
push
@pre
,
$self
->{confirm};
}
$chosen_file
= choose(
[
@pre
,
sort
(
@files
) ],
{
info
=>
$self
->{info},
prompt
=>
$prompt
,
alignment
=>
$self
->{alignment},
layout
=>
$self
->{layout},
order
=>
$self
->{order},
mouse
=>
$self
->{mouse},
clear_screen
=>
$self
->{clear_screen},
hide_cursor
=>
$self
->{hide_cursor},
color
=>
$self
->{color},
tabs_info
=>
$self
->{tabs_info},
tabs_prompt
=>
$self
->{tabs_prompt},
page
=>
$self
->{page},
footer
=>
$self
->{footer},
keep
=>
$self
->{keep},
undef
=>
$self
->{back},
margin
=>
$self
->{margin} }
);
if
( !
length
$chosen_file
) {
if
(
length
$prev_dir
) {
$prev_dir
=
''
;
next
;
}
return
;
}
elsif
(
$chosen_file
eq
$self
->{confirm} ) {
return
if
!
length
$prev_dir
;
return
catfile
$dir
,
$prev_dir
;
}
else
{
$prev_dir
=
$chosen_file
;
}
}
}
sub
choose_a_number {
if
(
ref
$_
[0] ne __PACKAGE__ ) {
my
$ob
= __PACKAGE__->new();
delete
$ob
->{backup_instance_defaults};
return
$ob
->choose_a_number(
@_
);
}
my
(
$self
,
$digits
,
$opt
) =
@_
;
my
$default_digits
= 7;
if
(
ref
$digits
) {
$opt
=
$digits
;
$digits
=
$default_digits
;
}
elsif
( !
$digits
) {
$digits
=
$default_digits
;
}
$self
->__prepare_opt(
$opt
);
my
$tab
=
' - '
;
my
$tab_w
= print_columns(
$tab
);
my
$sep_w
= print_columns_ext(
$self
->{thousands_separator},
$self
->{color} );
my
$longest
=
$digits
+
int
( (
$digits
- 1 ) / 3 ) *
$sep_w
;
my
@ranges
= ();
for
my
$di
( 0 ..
$digits
- 1 ) {
my
$begin
= 1 .
'0'
x
$di
;
$begin
= 0
if
$di
== 0;
$begin
= insert_sep(
$begin
,
$self
->{thousands_separator} );
(
my
$end
=
$begin
) =~ s/^[01]/9/;
unshift
@ranges
, unicode_sprintf(
$begin
,
$longest
, {
right_justify
=> 1,
color
=>
$self
->{color} } )
.
$tab
. unicode_sprintf(
$end
,
$longest
, {
right_justify
=> 1,
color
=>
$self
->{color} } );
}
my
$back_tmp
= unicode_sprintf(
$self
->{back},
$longest
* 2 +
$tab_w
+ 1, {
color
=>
$self
->{color} } );
my
$confirm_tmp
= unicode_sprintf(
$self
->{confirm},
$longest
* 2 +
$tab_w
+ 1, {
color
=>
$self
->{color} } );
if
( print_columns_ext(
$ranges
[0],
$self
->{color} ) > get_term_width() ) {
@ranges
= ();
for
my
$di
( 0 ..
$digits
- 1 ) {
my
$begin
= 1 .
'0'
x
$di
;
$begin
= 0
if
$di
== 0;
$begin
= insert_sep(
$begin
,
$self
->{thousands_separator} );
unshift
@ranges
, unicode_sprintf(
$begin
,
$longest
, {
color
=>
$self
->{color} } );
}
$confirm_tmp
=
$self
->{confirm};
$back_tmp
=
$self
->{back};
}
my
%numbers
;
my
$result
;
if
(
defined
$self
->{default_number} &&
length
$self
->{default_number} <=
$digits
) {
my
$count_zeros
= 0;
for
my
$d
(
reverse
split
''
,
$self
->{default_number} ) {
$numbers
{
$count_zeros
} =
$d
* 10 **
$count_zeros
;
$count_zeros
++;
}
$result
= sum(
@numbers
{
keys
%numbers
} );
$result
= insert_sep(
$result
,
$self
->{thousands_separator} );
}
NUMBER:
while
( 1 ) {
my
$cs_row
;
if
(
defined
$self
->{cs_label} ||
length
$result
) {
my
$tmp_result
=
length
$result
?
$result
:
''
;
my
$tmp_cs_label
=
$self
->{cs_label} //
''
;
$cs_row
=
sprintf
(
"%s%*s"
,
$tmp_cs_label
,
$longest
,
$tmp_result
);
if
( print_columns(
$cs_row
) > get_term_width() ) {
$cs_row
=
$tmp_result
;
}
}
my
@tmp_prompt
;
if
(
defined
$cs_row
) {
push
@tmp_prompt
,
$cs_row
;
}
if
(
length
$self
->{prompt} ) {
push
@tmp_prompt
,
$self
->{prompt};
}
my
$prompt
=
join
"\n"
,
@tmp_prompt
;
my
@pre
= (
undef
,
$confirm_tmp
);
my
$range
= choose(
$self
->{small_first} ? [
@pre
,
reverse
@ranges
] : [
@pre
,
@ranges
],
{
info
=>
$self
->{info},
prompt
=>
$prompt
,
layout
=> 2,
alignment
=> 1,
mouse
=>
$self
->{mouse},
clear_screen
=>
$self
->{clear_screen},
hide_cursor
=>
$self
->{hide_cursor},
color
=>
$self
->{color},
tabs_info
=>
$self
->{tabs_info},
tabs_prompt
=>
$self
->{tabs_prompt},
page
=>
$self
->{page},
footer
=>
$self
->{footer},
keep
=>
$self
->{keep},
undef
=>
$back_tmp
,
margin
=>
$self
->{margin} }
);
if
( !
defined
$range
) {
if
(
defined
$result
) {
$result
=
undef
;
%numbers
= ();
next
NUMBER;
}
else
{
$self
->__restore_defaults();
return
;
}
}
if
(
$range
eq
$confirm_tmp
) {
$result
= _remove_thousands_separators(
$result
,
$self
->{thousands_separator} );
$self
->__restore_defaults();
return
$result
;
}
my
$zeros
= (
split
/\s*-\s*/,
$range
)[0];
$zeros
=~ s/^\s*\d//;
my
$zeros_no_sep
= _remove_thousands_separators(
$zeros
,
$self
->{thousands_separator} );
my
$count_zeros
=
length
$zeros_no_sep
;
my
@choices
=
$count_zeros
?
map
(
$_
.
$zeros
, 1 .. 9 ) : ( 0 .. 9 );
my
$number
= choose(
[
undef
,
@choices
,
$self
->{
reset
} ],
{
info
=>
$self
->{info},
prompt
=>
$prompt
,
layout
=> 1,
alignment
=> 2,
order
=> 0,
mouse
=>
$self
->{mouse},
clear_screen
=>
$self
->{clear_screen},
hide_cursor
=>
$self
->{hide_cursor},
color
=>
$self
->{color},
tabs_info
=>
$self
->{tabs_info},
tabs_prompt
=>
$self
->{tabs_prompt},
page
=>
$self
->{page},
footer
=>
$self
->{footer},
keep
=>
$self
->{keep},
undef
=>
'<<'
,
margin
=>
$self
->{margin} }
);
next
if
!
defined
$number
;
if
(
$number
eq
$self
->{
reset
} ) {
delete
$numbers
{
$count_zeros
};
}
else
{
$numbers
{
$count_zeros
} = _remove_thousands_separators(
$number
,
$self
->{thousands_separator} );
}
$result
= sum(
@numbers
{
keys
%numbers
} );
$result
= insert_sep(
$result
,
$self
->{thousands_separator} );
}
}
sub
_remove_thousands_separators {
my
(
$str
,
$sep
) =
@_
;
if
(
defined
$str
&&
$sep
ne
''
) {
$str
=~ s/\Q
$sep
\E//g;
}
return
$str
;
}
sub
choose_a_subset {
if
(
ref
$_
[0] ne __PACKAGE__ ) {
my
$ob
= __PACKAGE__->new();
delete
$ob
->{backup_instance_defaults};
return
$ob
->choose_a_subset(
@_
);
}
my
(
$self
,
$available
,
$opt
) =
@_
;
my
$subseq_tab
=
length
$opt
->{cs_label} ? 2 : 0;
$self
->__prepare_opt(
$opt
,
$subseq_tab
);
my
$new_idx
= [];
my
$curr_avail
= [
@$available
];
my
$bu
= [];
my
@pre
= (
undef
,
$self
->{confirm} );
while
( 1 ) {
my
@tmp_prompt
;
my
$cs
;
if
(
defined
$self
->{cs_label} ) {
$cs
.=
$self
->{cs_label};
}
if
(
@$new_idx
) {
$cs
.=
$self
->{cs_begin} .
join
(
$self
->{cs_separator},
map
{
defined
$_
?
$_
:
''
} @{
$available
}[
@$new_idx
] ) .
$self
->{cs_end};
}
elsif
(
$opt
->{all_by_default} ) {
$cs
.=
$self
->{cs_begin} .
'*'
.
$self
->{cs_end};
}
if
(
defined
$cs
) {
@tmp_prompt
= (
$cs
);
}
if
(
length
$self
->{prompt} ) {
push
@tmp_prompt
,
$self
->{prompt};
}
my
$mark
;
if
(
defined
$self
->{mark} && @{
$self
->{mark}} ) {
$mark
= [
map
{
$_
+
@pre
} @{
$self
->{mark}} ];
}
my
$meta_items
= [ 0 ..
$#pre
];
my
$prompt
=
join
"\n"
,
@tmp_prompt
;
my
@idx
= choose(
[
@pre
,
length
(
$self
->{prefix} ) ?
map
{
$self
->{prefix} . (
defined
$_
?
$_
:
''
) }
@$curr_avail
:
@$curr_avail
],
{
info
=>
$self
->{info},
prompt
=>
$prompt
,
layout
=>
$self
->{layout},
index
=> 1,
alignment
=>
$self
->{alignment},
order
=>
$self
->{order},
mouse
=>
$self
->{mouse},
meta_items
=>
$meta_items
,
mark
=>
$mark
,
include_highlighted
=> 2,
clear_screen
=>
$self
->{clear_screen},
hide_cursor
=>
$self
->{hide_cursor},
color
=>
$self
->{color},
tabs_info
=>
$self
->{tabs_info},
tabs_prompt
=>
$self
->{tabs_prompt},
page
=>
$self
->{page},
footer
=>
$self
->{footer},
keep
=>
$self
->{keep},
undef
=>
$self
->{back},
busy_string
=>
$self
->{busy_string},
margin
=>
$self
->{margin} }
);
$self
->{mark} =
$mark
=
undef
;
if
( !
defined
$idx
[0] ||
$idx
[0] == 0 ) {
if
(
@$bu
) {
(
$curr_avail
,
$new_idx
) = @{
pop
@$bu
};
next
;
}
$self
->__restore_defaults();
return
;
}
push
@$bu
, [ [
@$curr_avail
], [
@$new_idx
] ];
my
$ok
;
if
(
$idx
[0] ==
$#pre
) {
$ok
=
shift
@idx
;
}
my
@tmp_idx
;
for
my
$i
(
reverse
@idx
) {
$i
-=
@pre
;
if
( !
$self
->{keep_chosen} ) {
splice
(
@$curr_avail
,
$i
, 1 );
for
my
$used_i
(
sort
{
$a
<=>
$b
}
@$new_idx
) {
last
if
$used_i
>
$i
;
++
$i
;
}
}
push
@tmp_idx
,
$i
;
}
push
@$new_idx
,
reverse
@tmp_idx
;
if
(
$ok
) {
if
( !
@$new_idx
&&
$opt
->{all_by_default} ) {
$new_idx
= [ 0 .. $
}
my
$return_indexes
=
$self
->{
index
};
$self
->__restore_defaults();
return
$return_indexes
?
$new_idx
: [ @{
$available
}[
@$new_idx
] ];
}
}
}
sub
settings_menu {
if
(
ref
$_
[0] ne __PACKAGE__ ) {
my
$ob
= __PACKAGE__->new();
delete
$ob
->{backup_instance_defaults};
return
$ob
->settings_menu(
@_
);
}
my
(
$self
,
$menu
,
$curr
,
$opt
) =
@_
;
$self
->__prepare_opt(
$opt
);
my
$longest
= 0;
my
$new
= {};
my
$name_w
= {};
for
my
$sub
(
@$menu
) {
my
(
$key
,
$name
,
$values
) =
@$sub
;
$name_w
->{
$key
} = print_columns_ext(
$name
,
$self
->{color} );
if
(
$name_w
->{
$key
} >
$longest
) {
$longest
=
$name_w
->{
$key
};
}
$curr
->{
$key
} = 0
if
!
defined
$curr
->{
$key
};
$curr
->{
$key
} = 0
if
$curr
->{
$key
} >
$#$values
;
$curr
->{
$key
} = 0
if
!
defined
$values
->[
$curr
->{
$key
}];
while
( !
defined
$values
->[
$curr
->{
$key
}] ) {
++
$curr
->{
$key
};
if
(
$curr
->{
$key
} >
$#$values
) {
$curr
->{
$key
} = 0;
last
;
}
}
$new
->{
$key
} =
$curr
->{
$key
};
}
my
@print_keys
;
for
my
$sub
(
@$menu
) {
my
(
$key
,
$name
,
$values
) =
@$sub
;
my
$current
=
$values
->[
$new
->{
$key
}] //
''
;
push
@print_keys
,
$name
. (
' '
x (
$longest
-
$name_w
->{
$key
} ) ) .
" [$current]"
;
}
my
@pre
= (
undef
,
$self
->{confirm} );
$ENV
{TC_RESET_AUTO_UP} = 0;
my
$default
= 0;
my
$count
= 0;
while
( 1 ) {
my
@tmp_prompt
;
if
(
defined
$self
->{cs_label} ) {
push
@tmp_prompt
,
$self
->{cs_label} .
$self
->{cs_begin} .
join
(
$self
->{cs_separator},
map
{
"$_=$new->{$_}"
}
keys
%$new
) .
$self
->{cs_end};
}
if
(
length
$self
->{prompt} ) {
push
@tmp_prompt
,
$self
->{prompt};
}
my
$prompt
=
join
(
"\n"
,
@tmp_prompt
);
my
$idx
= choose(
[
@pre
,
@print_keys
],
{
info
=>
$self
->{info},
prompt
=>
$prompt
,
index
=> 1,
default
=>
$default
,
layout
=> 2,
alignment
=> 0,
mouse
=>
$self
->{mouse},
clear_screen
=>
$self
->{clear_screen},
hide_cursor
=>
$self
->{hide_cursor},
color
=>
$self
->{color},
tabs_info
=>
$self
->{tabs_info},
tabs_prompt
=>
$self
->{tabs_prompt},
page
=>
$self
->{page},
footer
=>
$self
->{footer},
keep
=>
$self
->{keep},
undef
=>
$self
->{back},
margin
=>
$self
->{margin} }
);
if
( !
$idx
) {
$self
->__restore_defaults();
return
;
}
elsif
(
$idx
==
$#pre
) {
my
$change
= 0;
for
my
$sub
(
@$menu
) {
my
$key
=
$sub
->[0];
if
(
$curr
->{
$key
} ==
$new
->{
$key
} ) {
next
;
}
$curr
->{
$key
} =
$new
->{
$key
};
$change
++;
}
$self
->__restore_defaults();
return
$change
;
}
my
$i
=
$idx
-
@pre
;
my
$key
=
$menu
->[
$i
][0];
my
$values
=
$menu
->[
$i
][2];
if
(
$default
==
$idx
) {
if
(
$ENV
{TC_RESET_AUTO_UP} ) {
$count
= 0;
}
elsif
(
$count
==
@$values
) {
$default
= 0;
$count
= 0;
next
;
}
}
else
{
$count
= 0;
$default
=
$idx
;
}
my
$curr_value
=
$values
->[
$new
->{
$key
}] //
''
;
my
$new_value
;
while
( 1 ) {
++
$count
;
if
( ++
$new
->{
$key
} >
$#$values
) {
$new
->{
$key
} = 0;
}
$new_value
=
$values
->[
$new
->{
$key
}];
if
(
defined
$new_value
) {
last
;
}
if
(
$count
==
@$values
) {
$new_value
=
''
;
last
;
}
}
$print_keys
[
$i
] =~ s/ \[ \Q
$curr_value
\E \] \z /[
$new_value
]/x;
}
}
sub
insert_sep {
my
(
$number
,
$separator
) =
@_
;
return
$number
if
!
length
$number
;
$separator
=
','
if
!
defined
$separator
;
return
$number
if
$separator
eq
''
;
return
$number
if
$number
=~ /\Q
$separator
\E/;
$number
=~ s/(^[-+]?\d+?(?=(?>(?:\d{3})+)(?!\d))|\G\d{3}(?=\d))/$1
$separator
/g;
return
$number
;
}
sub
get_term_size {
return
Term::Choose::Screen::get_term_size();
}
sub
get_term_width {
my
$term_width
= ( Term::Choose::Screen::get_term_size() )[0];
return
$term_width
;
}
sub
get_term_height {
my
$term_height
= ( Term::Choose::Screen::get_term_size() )[1];
return
$term_height
;
}
sub
unicode_sprintf {
my
(
$str
,
$avail_w
,
$opt
) =
@_
;
$opt
||= {};
my
@color
;
if
(
$opt
->{color} ) {
$str
=~ s/${\PH}//g;
$str
=~ s/(${\SGR_ES})/
push
(
@color
, $1 ) && ${\PH}/ge;
}
my
$str_w
= print_columns(
$str
,
$avail_w
+ 1 );
if
(
$str_w
>
$avail_w
) {
if
( @{
$opt
->{suffix_on_truncate}||[]} ) {
$str
= cut_to_printwidth(
$str
,
$avail_w
-
$opt
->{suffix_on_truncate}[1] ) .
$opt
->{suffix_on_truncate}[0];
}
$str
= cut_to_printwidth(
$str
,
$avail_w
);
}
if
(
@color
) {
$str
=~ s/${\PH}/
shift
@color
/ge;
if
(
@color
) {
$str
.=
join
''
,
@color
;
}
}
if
(
$str_w
<
$avail_w
) {
if
(
$opt
->{right_justify} ) {
return
" "
x (
$avail_w
-
$str_w
) .
$str
;
}
else
{
return
$str
.
" "
x (
$avail_w
-
$str_w
);
}
}
else
{
return
$str
;
}
}
sub
print_columns_ext {
my
(
$str
,
$color
) =
@_
;
if
(
$color
) {
$str
=~ s/${\SGR_ES}//g;
}
return
print_columns(
$str
);
}
1;