File Coverage

blib/lib/Term/Choose/LineFold.pm
Criterion Covered Total %
statement 17 124 13.7
branch 1 60 1.6
condition 0 12 0.0
subroutine 6 10 60.0
pod 0 3 0.0
total 24 209 11.4


line stmt bran cond sub pod time code
1             package Term::Choose::LineFold;
2              
3 3     3   19 use warnings;
  3         5  
  3         94  
4 3     3   15 use strict;
  3         4  
  3         51  
5 3     3   28 use 5.10.0;
  3         10  
6              
7             our $VERSION = '1.762';
8              
9 3     3   19 use Exporter qw( import );
  3         8  
  3         368  
10              
11             our @EXPORT_OK = qw( line_fold print_columns cut_to_printwidth );
12              
13              
14             BEGIN {
15 3 50   3   25 if ( $ENV{TC_AMBIGUOUS_WIDE} ) {
16 0         0 require Term::Choose::LineFold::CharWidthAmbiguousWide;
17 0         0 Term::Choose::LineFold::CharWidthAmbiguousWide->import( 'table_char_width' );
18             }
19             else {
20 3         1553 require Term::Choose::LineFold::CharWidthDefault;
21 3         1791 Term::Choose::LineFold::CharWidthDefault->import( 'table_char_width' );
22             }
23             }
24              
25              
26             my $table = table_char_width();
27              
28             my $cache = {};
29              
30              
31             sub _char_width {
32             #my $c = $_[0];
33 0     0     my $min = 0;
34 0           my $mid;
35 0           my $max = $#$table;
36 0 0 0       if ( $_[0] < $table->[0][0] || $_[0] > $table->[$max][1] ) {
37 0           return 1;
38             }
39 0           while ( $max >= $min ) {
40 0           $mid = int( ( $min + $max ) / 2 );
41 0 0         if ( $_[0] > $table->[$mid][1] ) {
    0          
42 0           $min = $mid + 1;
43             }
44             elsif ( $_[0] < $table->[$mid][0] ) {
45 0           $max = $mid - 1;
46             }
47             else {
48 0           return $table->[$mid][2];
49             }
50             }
51 0           return 1;
52             }
53              
54              
55             sub print_columns {
56             #my $str = $_[0];
57 0     0 0   my $width = 0;
58 0           my $c;
59 0           for my $i ( 0 .. ( length( $_[0] ) - 1 ) ) {
60 0           $c = ord substr $_[0], $i, 1;
61             $width = $width + (
62             defined $cache->{$c}
63             ? $cache->{$c}
64 0 0         : ( $cache->{$c} = _char_width( $c ) )
65             );
66             }
67 0           return $width;
68             }
69              
70              
71             sub cut_to_printwidth {
72 0     0 0   my ( $str, $avail_width, $return_remainder ) = @_;
73 0           my $count = 0;
74 0           my $total = 0;
75 0           my $c;
76 0           for my $i ( 0 .. ( length( $str ) - 1 ) ) {
77 0           $c = ord substr $str, $i, 1;
78 0 0         if ( ! defined $cache->{$c} ) {
79 0           $cache->{$c} = _char_width( $c )
80             }
81 0 0         if ( ( $total = $total + $cache->{$c} ) > $avail_width ) {
82 0 0         if ( ( $total - $cache->{$c} ) < $avail_width ) {
83 0 0         return substr( $str, 0, $count ) . ' ', substr( $str, $count ) if $return_remainder;
84 0           return substr( $str, 0, $count ) . ' ';
85             }
86 0 0         return substr( $str, 0, $count ), substr( $str, $count ) if $return_remainder;
87 0           return substr( $str, 0, $count );
88              
89             }
90 0           ++$count;
91             }
92 0 0         return $str, '' if $return_remainder;
93 0           return $str;
94             }
95              
96              
97             sub line_fold {
98 0     0 0   my ( $str, $avail_width, $opt ) = @_; #copy $str
99 0 0         if ( ! length $str ) {
100 0           return $str;
101             }
102 0           my $max_tab_width = int( $avail_width / 2 );
103 0           for ( $opt->{init_tab}, $opt->{subseq_tab} ) {
104 0 0         if ( length ) {
105 0           s/\t/ /g;
106 0           s/\v+/\ \ /g;
107 3     3   1927 s/[\p{Cc}\p{Noncharacter_Code_Point}\p{Cs}]//g;
  3         48  
  3         52  
  0            
108 0 0         if ( length > $max_tab_width ) {
109 0           $_ = cut_to_printwidth( $_, $max_tab_width );
110             }
111             }
112             else {
113 0           $_ = '';
114             }
115             }
116 0           my @color;
117 0 0         if ( $opt->{color} ) {
118 0           $str =~ s/\x{feff}//g;
119 0 0         $str =~ s/(\e\[[\d;]*m)/push( @color, $1 ) && "\x{feff}"/ge;
  0            
120             }
121 0 0 0       if ( $opt->{binary_filter} && substr( $str, 0, 100 ) =~ /[\x00-\x08\x0B-\x0C\x0E-\x1F]/ ) {
122             #$str = $self->{binary_filter} == 2 ? sprintf("%v02X", $_[0]) =~ tr/./ /r : 'BNRY'; # perl 5.14
123 0 0         if ( $opt->{binary_filter} == 2 ) {
124 0           ( $str = sprintf( "%v02X", $_[0] ) ) =~ tr/./ /; # use unmodified string
125             }
126             else {
127 0           $str = 'BNRY';
128             }
129             }
130 0           $str =~ s/\t/ /g;
131 0           $str =~ s/[^\v\P{Cc}]//g; # remove control chars but keep vertical spaces
132 0           $str =~ s/[\p{Noncharacter_Code_Point}\p{Cs}]//g;
133 0 0 0       if ( $str !~ /\R/ && print_columns( $opt->{init_tab} . $str ) <= $avail_width && ! @color ) {
      0        
134 0           return $opt->{init_tab} . $str;
135             }
136 0           my @paragraphs;
137              
138 0           for my $row ( split /\R/, $str, -1 ) { # -1 to keep trailing empty fields
139 0           my @lines;
140 0           $row =~ s/\s+\z//;
141 0           my @words = split( /(?<=\S)(?=\s)/, $row );
142 0           my $line = $opt->{init_tab};
143              
144 0           for my $i ( 0 .. $#words ) {
145 0 0         if ( print_columns( $line . $words[$i] ) <= $avail_width ) {
146 0           $line .= $words[$i];
147             }
148             else {
149 0           my $tmp;
150 0 0         if ( $i == 0 ) {
151 0           $tmp = $opt->{init_tab} . $words[$i];
152             }
153             else {
154 0           push( @lines, $line );
155 0           $words[$i] =~ s/^\s+//;
156 0           $tmp = $opt->{subseq_tab} . $words[$i];
157             }
158 0           ( $line, my $remainder ) = cut_to_printwidth( $tmp, $avail_width, 1 );
159 0           while ( length $remainder ) {
160 0           push( @lines, $line );
161 0           $tmp = $opt->{subseq_tab} . $remainder;
162 0           ( $line, $remainder ) = cut_to_printwidth( $tmp, $avail_width, 1 );
163             }
164             }
165 0 0         if ( $i == $#words ) {
166 0           push( @lines, $line );
167             }
168             }
169 0 0         if ( $opt->{join} ) {
170 0           push( @paragraphs, join( "\n", @lines ) );
171             }
172             else {
173 0 0         if ( @lines ) {
174 0           push( @paragraphs, @lines );
175             }
176             else {
177 0           push( @paragraphs, '' );
178             }
179             }
180             }
181 0 0         if ( @color ) {
182 0           my $last_color;
183 0           for my $paragraph ( @paragraphs ) {
184 0 0         if ( ! $opt->{join} ) {
185 0 0         if ( $last_color ) {
186 0           $paragraph = $last_color . $paragraph;
187             }
188 0           my $count = () = $paragraph =~ /\x{feff}/g;
189 0 0         if ( $count ) {
190 0           $last_color = $color[$count - 1];
191             }
192             }
193 0           $paragraph =~ s/\x{feff}/shift @color/ge;
  0            
194 0 0         if ( ! @color ) {
195 0           last;
196             }
197             }
198 0           $paragraphs[-1] .= "\e[0m";
199             }
200 0 0         if ( $opt->{join} ) {
201 0           return join( "\n", @paragraphs );
202             }
203             else {
204 0           return @paragraphs;
205             }
206             }
207              
208              
209              
210              
211              
212              
213              
214              
215              
216              
217             1;