File Coverage

blib/lib/Term/Choose_HAE.pm
Criterion Covered Total %
statement 35 134 26.1
branch 0 68 0.0
condition 0 33 0.0
subroutine 12 18 66.6
pod 1 1 100.0
total 48 254 18.9


line stmt bran cond sub pod time code
1             package Term::Choose_HAE;
2              
3 2     2   137659 use warnings;
  2         13  
  2         65  
4 2     2   10 use strict;
  2         5  
  2         37  
5 2     2   58 use 5.010001;
  2         8  
6              
7             our $VERSION = '0.057';
8 2     2   19 use Exporter 'import';
  2         5  
  2         95  
9             our @EXPORT_OK = qw( choose );
10              
11 2     2   974 use Parse::ANSIColor::Tiny qw();
  2         11940  
  2         68  
12 2     2   1337 use Term::ANSIColor qw( colored );
  2         15898  
  2         1565  
13 2     2   1042 use Text::ANSI::WideUtil qw( ta_mbtrunc );
  2         122896  
  2         147  
14              
15 2     2   1171 use if $^O eq 'MSWin32', 'Win32::Console::ANSI';
  2         29  
  2         15  
16              
17 2     2   947 use Term::Choose::Constants qw( :choose :screen :linux );
  2         2294  
  2         603  
18 2     2   854 use Term::Choose::LineFold qw( print_columns );
  2         9442  
  2         129  
19              
20 2     2   881 use parent 'Term::Choose';
  2         597  
  2         11  
21              
22              
23              
24             sub __valid_options {
25 111     111   47080 my $valid = Term::Choose::__valid_options();
26 111         1530 $valid->{fill_up} = '[ 0 1 2 ]';
27 111         281 return $valid;
28             };
29              
30              
31             sub __defaults {
32 0     0     my ( $self ) = @_;
33 0           my $defaults = Term::Choose::__defaults();
34 0           $defaults->{fill_up} = 1;
35 0           return $defaults;
36             }
37              
38              
39             sub choose {
40 0 0   0 1   if ( ref $_[0] ne 'Term::Choose_HAE' ) {
41 0           return Term::Choose_HAE->new()->Term::Choose::__choose( @_ );
42             }
43 0           my $self = shift;
44 0           return $self->Term::Choose::__choose( @_ );
45             }
46              
47              
48             sub __copy_orig_list {
49 0     0     my ( $self, $orig_list ) = @_;
50 0           $self->{list} = [ @$orig_list ];
51 0 0         if ( $self->{ll} ) {
52 0           for ( @{$self->{list}} ) {
  0            
53 0 0         $_ = $self->{undef} if ! defined $_;
54             }
55             }
56             else {
57 0           for ( @{$self->{list}} ) {
  0            
58 0 0         if ( ! $_ ) {
59 0 0         $_ = $self->{undef} if ! defined $_;
60 0 0         $_ = $self->{empty} if $_ eq '';
61             }
62 0 0         if ( ref ) {
63 0           $_ = sprintf "%s(0x%x)", ref $_, $_;
64             }
65 0           s/\t/ /g;
66 0           s/[\x{000a}-\x{000d}\x{0085}\x{2028}\x{2029}]+/\ \ /g; # \v 5.10
67 0 0         s/[\p{Cc}\p{Noncharacter_Code_Point}\p{Cs}]/$&=~m|\e| && $&/eg; # remove \p{Cc} but keep \e\[
  0            
68             }
69             }
70             }
71              
72              
73             sub __length_longest {
74 0     0     my ( $self ) = @_;
75 0           my $list = $self->{list};
76 0 0         if ( $self->{ll} ) {
77 0           $self->{length_longest} = $self->{ll};
78 0           $self->{length} = [ ( $self->{length_longest} ) x @$list ];
79             }
80             else {
81 0           my $len = [];
82 0           my $longest = 0;
83 0           for my $i ( 0 .. $#$list ) {
84 0           $len->[$i] = print_columns( _strip_ansi_color( $list->[$i] ) );
85 0 0         $longest = $len->[$i] if $len->[$i] > $longest;
86             }
87 0           $self->{length_longest} = $longest;
88 0           $self->{length} = $len;
89             }
90             }
91              
92              
93             sub _strip_ansi_color {
94 0     0     ( my $str = $_[0] ) =~ s/\e\[[\d;]*m//msg;
95 0           return $str;
96             }
97              
98              
99             sub __unicode_sprintf {
100 0     0     my ( $self, $idx, $is_current_pos, $is_marked ) = @_;
101 0           my $unicode = '';
102 0           my $str_length = $self->{length}[$idx];
103 0 0         if ( $str_length > $self->{avail_col_width} ) {
    0          
104 0 0         if ( $self->{avail_col_width} > 3 ) {
105 0           $unicode = ta_mbtrunc( $self->{list}[$idx], $self->{avail_col_width} - 3 ) . '...';
106             }
107             else {
108 0           $unicode = ta_mbtrunc( $self->{list}[$idx], $self->{avail_col_width} );
109             }
110             }
111             elsif ( $str_length < $self->{avail_col_width} ) {
112 0 0         if ( $self->{justify} == 0 ) {
    0          
    0          
113 0           $unicode = $self->{list}[$idx] . " " x ( $self->{avail_col_width} - $str_length );
114             }
115             elsif ( $self->{justify} == 1 ) {
116 0           $unicode = " " x ( $self->{avail_col_width} - $str_length ) . $self->{list}[$idx];
117             }
118             elsif ( $self->{justify} == 2 ) {
119 0           my $all = $self->{avail_col_width} - $str_length;
120 0           my $half = int( $all / 2 );
121 0           $unicode = " " x $half . $self->{list}[$idx] . " " x ( $all - $half );
122             }
123             }
124             else {
125 0           $unicode = $self->{list}[$idx];
126             }
127              
128 0           my $wrap = '';
129 0 0         open my $trapstdout, '>', \$wrap or die "can't open TRAPSTDOUT: $!";
130 0           select $trapstdout;
131 0 0         print BOLD_UNDERLINE if $is_marked;
132 0 0         print REVERSE if $is_current_pos;
133 0           select STDOUT;
134 0           close $trapstdout;
135 0           my $ansi = Parse::ANSIColor::Tiny->new();
136 0           my @codes = ( $wrap =~ /\e\[([\d;]*)m/g );
137 0 0         my @attr = $ansi->identify( @codes ? @codes : '' );
138 0           my $marked = $ansi->parse( $unicode );
139 0 0 0       if ( $self->{length}[$idx] > $self->{avail_width} && $self->{fill_up} != 2 ) {
140 0 0 0       if ( @$marked > 1 && ! @{$marked->[-1][0]} && $marked->[-1][1] =~ /^\.\.\.\z/ ) {
  0   0        
141 0           $marked->[-1][0] = $marked->[-2][0];
142             }
143             }
144 0 0         if ( $attr[0] ne 'clear' ) {
145 0 0 0       if ( $self->{fill_up} == 1 && @$marked > 1 ) {
146 0 0 0       if ( ! @{$marked->[0][0]} && $marked->[0][1] =~ /^\s+\z/ ) {
  0            
147 0           $marked->[0][0] = $marked->[1][0];
148             }
149 0 0 0       if ( ! @{$marked->[-1][0]}&& $marked->[-1][1] =~ /^\s+\z/ ) {
  0            
150 0           $marked->[-1][0] = $marked->[-2][0];
151             }
152             }
153 0 0         if ( ! $self->{fill_up} ) {
154 0 0 0       if ( ! @{$marked->[0][0]} && $marked->[0][1] =~ /^(\s+)\S/ ) {
  0 0 0        
155 0           my $tmp = $1;
156 0           $marked->[0][1] =~ s/^\s+//;
157 0           unshift @$marked, [ [], $tmp ];
158             }
159 0           elsif ( ! @{$marked->[-1][0]} && $marked->[-1][1] =~ /\S(\s+)\z/ ) {
160 0           my $tmp = $1;
161 0           $marked->[-1][1] =~ s/\s+\z//;
162 0           push @$marked, [ [], $tmp ];
163             }
164             }
165 0           for my $i ( 0 .. $#$marked ) {
166 0 0         if ( ! $self->{fill_up} ) {
167 0 0 0       if ( $i == 0 || $i == $#$marked ) {
168 0 0 0       if ( ! @{$marked->[$i][0]} && $marked->[$i][1] =~ /^\s+\z/ ) {
  0            
169 0           next;
170             }
171             }
172             }
173 0           $marked->[$i][0] = [ $ansi->normalize( @{ $marked->[$i][0] }, @attr ) ];
  0            
174             }
175             }
176 0 0         print join '', map { @{$_->[0]} ? colored( @$_ ) : $_->[1] } @$marked;
  0            
  0            
177 0 0 0       if ( $is_marked || $is_current_pos ) {
178 0           print RESET;
179             }
180             }
181              
182              
183              
184              
185             1;
186              
187              
188             __END__