File Coverage

blib/lib/Text/ANSI/BaseUtil.pm
Criterion Covered Total %
statement 395 462 85.5
branch 179 246 72.7
condition 73 101 72.2
subroutine 25 32 78.1
pod 0 20 0.0
total 672 861 78.0


line stmt bran cond sub pod time code
1             package Text::ANSI::BaseUtil;
2              
3             our $DATE = '2021-04-14'; # DATE
4             our $VERSION = '0.232'; # VERSION
5              
6 1     1   18 use 5.010001;
  1         3  
7 1     1   5 use strict;
  1         2  
  1         19  
8 1     1   5 use warnings;
  1         2  
  1         28  
9              
10 1     1   6 use List::Util qw(min max);
  1         1  
  1         4704  
11              
12             our $re = qr/\e\[[0-9;]+m/s;
13             our $re_mult = qr/(?:\e\[[0-9;]+m)+/s;
14              
15             sub ta_detect {
16 4     4 0 1327 my $text = shift;
17 4 100       45 $text =~ $re ? 1:0;
18             }
19              
20             sub ta_length {
21 30     30 0 2754 my $text = shift;
22 30         67 length(ta_strip($text));
23             }
24              
25             sub _ta_length_height {
26 5     5   13 my ($is_mb, $text) = @_;
27 5         8 my $num_lines = 0;
28 5         9 my @lens;
29 5         10 for my $e (split /(\r?\n)/, ta_strip($text)) {
30 7 100       22 if ($e =~ /\n/) {
31 3         5 $num_lines++;
32 3         8 next;
33             }
34 4 100       11 $num_lines = 1 if $num_lines == 0;
35 4 50       13 push @lens, $is_mb ? Text::WideChar::Util::mbswidth($e) : length($e);
36             }
37 5   100     46 [max(@lens) // 0, $num_lines];
38             }
39              
40             sub ta_length_height {
41 5     5 0 2724 _ta_length_height(0, @_);
42             }
43              
44             sub ta_mbswidth_height {
45 0     0 0 0 _ta_length_height(1, @_);
46             }
47              
48             sub ta_strip {
49 38     38 0 2724 my $text = shift;
50 38         235 $text =~ s/$re//go;
51 38         143 $text;
52             }
53              
54             sub ta_extract_codes {
55 6     6 0 2710 my $text = shift;
56 6         12 my $res = "";
57 6         98 $res .= $1 while $text =~ /($re_mult)/go;
58 6         26 $res;
59             }
60              
61             sub ta_split_codes {
62 7     7 0 2691 my $text = shift;
63 7         139 return split(/($re_mult)/o, $text);
64             }
65              
66             sub ta_split_codes_single {
67 29     29 0 2820 my $text = shift;
68 29         274 return split(/($re)/o, $text);
69             }
70              
71             # same like _ta_mbswidth, but without handling multiline text
72             sub _ta_mbswidth0 {
73 0     0   0 my $text = shift;
74 0         0 Text::WideChar::Util::mbswidth(ta_strip($text));
75             }
76              
77             sub ta_mbswidth {
78 0     0 0 0 my $text = shift;
79 0         0 ta_mbswidth_height($text)->[0];
80             }
81              
82             sub _ta_wrap {
83 8     8   27 my ($is_mb, $text, $width, $opts) = @_;
84 8   50     28 $width //= 80;
85 8   100     44 $opts //= {};
86              
87             # basically similar to Text::WideChar::Util's algorithm. we adjust for
88             # dealing with ANSI codes by splitting codes first (to easily do color
89             # resets/replays), then grouping into words and paras, then doing wrapping.
90              
91 8 50       48 my $_re1 = $is_mb ?
92             qr/($Text::WideChar::Util::re_cjk+)|(\S+)|(\s+)/ :
93             qr/()(\S+)|(\s+)/;
94              
95 8 50       20 my $_re2 = $is_mb ?
96             qr/($Text::WideChar::Util::re_cjk_class+)|
97             ($Text::WideChar::Util::re_cjk_negclass+)/x : undef;
98              
99 8         41 my @termst; # store term type, 's' (spaces), 'w' (word), 'c' (cjk word) or
100             # 'p' (parabreak)
101             my @terms; # store the text (w/ codes); for ws, only store the codes
102 8         0 my @pterms; # store the plaintext ver, but only for ws to check parabreak
103 8         0 my @termsw; # store width of each term, only for non-ws
104 8         0 my @termsc; # store color replay code
105             {
106 8         21 my @ch = ta_split_codes_single($text);
107 8         21 my $crcode = ""; # code for color replay to be put at the start of line
108 8         16 my $term = '';
109 8         16 my $pterm = '';
110 8         13 my $prev_type = '';
111 8         37 while (my ($pt, $c) = splice(@ch, 0, 2)) {
112             #use Data::Dump; print "D:chunk: "; dd [$pt, $c];
113              
114             # split into (CJK and non-CJK) words and spaces.
115              
116 20         34 my @s; # (WORD1, TYPE, ...) where type is 's' for space, 'c' for
117             # CJK word, or 'w' for non-CJK word
118 20         120 while ($pt =~ /$_re1/g) {
119 229 50 33     593 if ($is_mb && $1) {
    100          
120 0         0 push @s, $1, 'c';
121             } elsif ($3) {
122 112         448 push @s, $3, 's';
123             } else {
124 117 50       168 if ($is_mb) {
125 0         0 my $pt2 = $2;
126 0         0 while ($pt2 =~ /$_re2/g) {
127 0 0       0 if ($1) {
128 0         0 push @s, $1, 'c';
129             } else {
130 0         0 push @s, $2, 'w';
131             }
132             }
133             } else {
134 117         494 push @s, $2, 'w';
135             }
136             }
137             }
138              
139             #use Data::Dump; say "D:s=",Data::Dump::dump(\@s);
140              
141 20 100       37 my $only_code; $only_code = 1 if !@s;
  20         42  
142 20         31 while (1) {
143 249         457 my ($s, $s_type) = splice @s, 0, 2;
144 249   100     480 $s_type //= '';
145 249 100 100     700 last unless $only_code || defined($s);
146             # empty text, only code
147 233 100       409 if ($only_code) {
148 4         8 $s = "";
149 4 50       38 $term .= $c if defined $c;
150             }
151             #say "D:s=[$s] prev_type=$prev_type \@ch=",~~@ch," \@s=",~~@s;
152              
153 233 100 100     677 if ($s_type && $s_type ne 's') {
    100          
154 117 100 33     220 if ($prev_type eq 's') {
    50          
155             #say "D:found word, completed previous ws [$term]";
156 109         166 push @termst, 's';
157 109         174 push @terms , $term;
158 109         162 push @pterms, $pterm;
159 109         152 push @termsw, undef;
160 109         150 push @termsc, $crcode;
161             # start new word
162 109         142 $pterm = ''; $term = '';
  109         136  
163             } elsif ($prev_type && $prev_type ne $s_type) {
164             #say "D:found a ".($s_type eq 'c' ? 'CJK':'non-CJK')." word, completed previous ".($prev_type eq 'c' ? 'CJK':'non-CJK')." word [$term]";
165 0         0 push @termst, $prev_type;
166 0         0 push @terms , $term;
167 0         0 push @pterms, $pterm;
168 0 0       0 push @termsw, $is_mb ? Text::WideChar::Util::mbswidth($pterm):length($pterm);
169 0         0 push @termsc, $crcode;
170             # start new word
171 0         0 $pterm = ''; $term = '';
  0         0  
172             }
173 117         161 $pterm .= $s;
174 117 100 100     152 $term .= $s; $term .= $c if defined($c) && !@s;
  117         273  
175 117 100 100     237 if (!@s && !@ch) {
176             #say "D:complete word because this is the last token";
177 6         12 push @termst, $s_type;
178 6         12 push @terms , $term;
179 6         10 push @pterms, "";
180 6 50       16 push @termsw, $is_mb ? Text::WideChar::Util::mbswidth($pterm):length($pterm);
181 6         12 push @termsc, $crcode;
182             }
183             } elsif (length($s)) {
184 112 100       183 if ($prev_type ne 's') {
185             #say "D:found ws, completed previous word [$term]";
186 111         179 push @termst, $prev_type;
187 111         186 push @terms , $term;
188 111         160 push @pterms, "";
189 111 50       195 push @termsw, $is_mb ? Text::WideChar::Util::mbswidth($pterm):length($pterm);
190 111         181 push @termsc, $crcode;
191             # start new ws
192 111         143 $pterm = ''; $term = '';
  111         146  
193             }
194 112         157 $pterm .= $s;
195 112 100 100     222 $term .= $c if defined($c) && !@s;
196 112 100 100     217 if (!@s && !@ch) {
197             #say "D:complete ws because this is the last token";
198 2         4 push @termst, 's';
199 2         4 push @terms , $term;
200 2         3 push @pterms, $pterm;
201 2         4 push @termsw, undef;
202 2         14 push @termsc, $crcode;
203             }
204             }
205 233         327 $prev_type = $s_type;
206              
207 233 100       413 if (!@s) {
208 20 100 66     86 if (defined($c) && $c =~ /m\z/) {
209 13 100       46 if ($c eq "\e[0m") {
    50          
210             #say "D:found color reset, emptying crcode";
211 6         8 $crcode = "";
212             } elsif ($c =~ /m\z/) {
213             #say "D:adding to crcode";
214 7         14 $crcode .= $c;
215             }
216             }
217 20 100       55 last if $only_code;
218             }
219              
220             } # splice @s
221             } # splice @ch
222             }
223              
224             # mark parabreaks
225             {
226 8         12 my $i = 0;
  8         14  
  8         15  
227 8         23 while ($i < @pterms) {
228 228 100       434 if ($termst[$i] eq 's') {
229 111 100       208 if ($pterms[$i] =~ /[ \t]*(\n(?:[ \t]*\n)+)([ \t]*)/) {
230             #say "D:found parabreak";
231 2         10 $pterms[$i] = $1;
232 2         4 $termst[$i] = 'p';
233 2 50       10 if ($i < @pterms-1) {
234             # stick color code to the beginning of next para
235 2         9 $terms [$i+1] = $terms[$i] . $terms [$i+1];
236 2         7 $terms [$i] = "";
237             }
238 2 50       8 if (length $2) {
239             #say "D:found space after parabreak, splitting";
240 0         0 splice @termst, $i+1, 0, "s";
241 0         0 splice @terms , $i+1, 0, "";
242 0         0 splice @pterms, $i+1, 0, $2;
243 0         0 splice @termsw, $i+1, 0, undef;
244 0         0 splice @termsc, $i+1, 0, $termsc[$i];
245 0         0 $i += 2;
246 0         0 next;
247             }
248             }
249             }
250 228         368 $i++;
251             }
252             }
253              
254             #use Data::Dump::Color; my @d; for (0..$#terms) { push @d, {type=>$termst[$_], term=>$terms[$_], pterm=>$pterms[$_], termc=>$termsc[$_], termw=>$termsw[$_], } } dd \@d;
255             #return;
256              
257             #use Data::Dump; say "D:termst=".Data::Dump::dump(\@termst);
258             #use Data::Dump; say "D:terms =".Data::Dump::dump(\@terms);
259             #use Data::Dump; say "D:pterms=".Data::Dump::dump(\@pterms);
260             #use Data::Dump; say "D:termsw=".Data::Dump::dump(\@termsw);
261             #use Data::Dump; say "D:termsc=".Data::Dump::dump(\@termsc);
262              
263 8         23 my ($maxww, $minww);
264              
265             # now we perform wrapping
266              
267 8         0 my @res;
268             {
269 8   50     12 my $tw = $opts->{tab_width} // 8;
  8         56  
270 8 50       20 die "Please specify a positive tab width" unless $tw > 0;
271 8         14 my $optfli = $opts->{flindent};
272 8 50       17 my $optfliw; $optfliw = Text::WideChar::Util::_get_indent_width($is_mb, $optfli, $tw) if defined $optfli;
  8         17  
273 8         46 my $optsli = $opts->{slindent};
274 8 50       16 my $optsliw; $optsliw = Text::WideChar::Util::_get_indent_width($is_mb, $optsli, $tw) if defined $optsli;
  8         17  
275 8   50     26 my $optkts = $opts->{keep_trailing_space} // 0;
276 8         17 my $pad = $opts->{pad};
277 8         9 my $x = 0;
278 8         14 my $y = 0;
279 8         16 my ($fli, $sli, $fliw, $sliw);
280 8         10 my $is_parastart = 1;
281 8         12 my $line_has_word = 0;
282 8         13 my ($termt, $prev_t);
283             TERM:
284 8         29 for my $i (0..$#terms) {
285 228 100       400 $prev_t = $termt if $i;
286 228         316 $termt = $termst[$i];
287 228         292 my $term = $terms[$i];
288 228         296 my $pterm = $pterms[$i];
289 228         286 my $termw = $termsw[$i];
290 228 100       401 my $crcode = $i > 0 ? $termsc[$i-1] : "";
291             #say "D:term=[", ($termt eq 'w' ? $term : $pterm), "] ($termt)";
292              
293             # end of paragraph
294 228 100       388 if ($termt eq 'p') {
295 2         6 my $numnl = 0;
296 2         19 $numnl++ while $pterm =~ /\n/g;
297 2         10 for (1..$numnl) {
298 4 50 33     12 push @res, "\e[0m" if $crcode && $_ == 1;
299 4 50       8 push @res, " " x ($width-$x) if $pad;
300 4         6 push @res, "\n";
301 4         7 $x = 0;
302 4         15 $y++;
303             }
304 2         5 $line_has_word = 0;
305 2         4 $x = 0;
306 2         3 $is_parastart = 1;
307 2         8 next TERM;
308             }
309              
310 226 100       357 if ($is_parastart) {
311             # this is the start of paragraph, determine indents
312 10 50       19 if (defined $optfli) {
313 0         0 $fli = $optfli;
314 0         0 $fliw = $optfliw;
315             } else {
316 10 50       23 if ($termt eq 's') {
317 0         0 $fli = $pterm;
318 0         0 $fliw = Text::WideChar::Util::_get_indent_width($is_mb, $fli, $tw);
319             } else {
320 10         19 $fli = "";
321 10         15 $fliw = 0;
322             }
323             #say "D:deduced fli from text [$fli] ($fliw)";
324 10         17 my $j = $i;
325 10         18 $sli = undef;
326 10   100     53 while ($j < @terms && $termst[$j] ne 'p') {
327 226 100       368 if ($termst[$j] eq 's') {
328 109 50       178 if ($pterms[$j] =~ /\n([ \t]+)/) {
329 0         0 $sli = $1;
330 0         0 $sliw = Text::WideChar::Util::_get_indent_width($is_mb, $sli, $tw);
331 0         0 last;
332             }
333             }
334 226         585 $j++;
335             }
336 10 50       26 if (!defined($sli)) {
337 10         12 $sli = "";
338 10         18 $sliw = 0;
339             }
340             #say "D:deduced sli from text [$sli] ($sliw)";
341 10 50       21 die "Subsequent indent must be less than width" if $sliw >= $width;
342             }
343              
344             #say "D:inserting the fli [$fli] ($fliw)";
345 10         17 push @res, $fli;
346 10         18 $x += $fliw;
347             } # parastart
348              
349 226         307 $is_parastart = 0;
350              
351 226 100       375 if ($termt eq 's') {
352             # just print the codes
353 109         172 push @res, $term;
354              
355             # maintain terminating newline
356 109 100 100     267 if ($pterm =~ /\n/ && $i == $#terms) {
357 2 50       6 push @res, "\e[0m" if $crcode;
358 2 50       5 push @res, " " x ($width-$x) if $pad;
359 2         4 push @res, "\n";
360 2         3 $line_has_word = 0;
361             }
362             }
363              
364 226 100       402 if ($termt ne 's') {
365             # we need to chop long words
366 117         287 my @words;
367             my @wordsw;
368 117         0 my @wordst; # c if cjk, w if not
369 117         0 my @wordswsb; # whether there are ws before the word
370 117         157 my $j = 0;
371 117         145 my $c = ""; # see below for explanation
372 117         145 while (1) {
373 120         142 $j++;
374             # most words shouldn't be that long. and we don't need to
375             # truncate long CJK word first here because it will get
376             # truncated later.
377 120 100 66     273 if ($termw <= $width-$sliw || $termt eq 'c') {
378 117         229 push @words , $c . $term;
379 117         170 push @wordsw , $termw;
380 117         159 push @wordst , $termt;
381 117 100 100     344 push @wordswsb, ($prev_t && $prev_t eq 's')?1:0;
382 117         156 last;
383             }
384             #use Data::Dump; print "D:truncating long word "; dd $term;
385 3 50       17 my $res = $is_mb ? ta_mbtrunc($term, $width-$sliw, 1) :
386             ta_trunc($term, $width-$sliw, 1);
387              
388 3         5 my ($tword, $twordw);
389 3 50       8 if ($j == 1) {
390 3         5 $tword = $res->[0];
391 3         7 $twordw = $res->[1];
392             } else {
393             # since ta_{,mb}trunc() adds the codes until the end of
394             # the word, to avoid messing colors, for the second word
395             # and so on we need to replay colors by prefixing with:
396             # \e[0m (reset) + $crcode + (all the codes from the
397             # start of the long word up until the truncated
398             # position, stored in $c).
399             #
400             # there might be faster way, but it is expected that
401             # long words are not that common.
402 0 0       0 $tword = ($crcode ? "\e[0m" . $crcode : "") .
403             $c . $res->[0];
404 0         0 $twordw = $res->[1];
405             }
406 3         10 $c .= ta_extract_codes(substr($term, 0, $res->[2]));
407             #use Data::Dump; print "D:truncated word is "; dd $tword;
408              
409 3         8 push @words , $tword;
410 3         6 push @wordsw , $twordw;
411 3         4 push @wordst , $termt;
412 3 100 66     14 push @wordswsb, $j == 1 ? (($prev_t && $prev_t eq 's')?1:0) : 0;
    50          
413 3         6 $term = substr($term, $res->[2]);
414 3 50       10 $termw = $is_mb ? _ta_mbswidth0($term) : ta_length($term);
415             }
416              
417             #use Data::Dump; print "D:words="; dd \@words; print "D:wordsw="; dd \@wordsw; print "D:wordswsb="; dd \@wordswsb;
418              
419             # the core of the wrapping algo
420 117         225 for my $word (@words) {
421 120         178 my $wordw = shift @wordsw;
422 120         158 my $wordt = shift @wordst;
423 120         161 my $ws_before = shift @wordswsb;
424             #say "D:x=$x word=$word wordw=$wordw wordt=$wordt ws_before=$ws_before line_has_word=$line_has_word width=$width";
425              
426 120 100 100     339 $maxww = $wordw if !defined($maxww) || $maxww < $wordw;
427 120 100 100     329 $minww = $wordw if !defined($minww) || $minww > $wordw;
428              
429 120 100       242 if ($x + ($line_has_word ? 1:0) + $wordw <= $width) {
    100          
430 104 100 66     265 if ($line_has_word && $ws_before) {
431 94         153 push @res, " ";
432 94         126 $x++;
433             }
434 104         172 push @res, $word;
435 104         135 $x += $wordw;
436             } else {
437             # line break
438 16         21 while (1) {
439 16 50       31 if ($wordt eq 'c') {
440             # a CJK word can be line-broken
441 0         0 my $res;
442 0 0       0 if ($ws_before) {
443 0         0 $res = ta_mbtrunc($word, $width-$x-1, 1);
444 0         0 push @res, " ", $res->[0];
445             } else {
446 0         0 $res = ta_mbtrunc($word, $width-$x, 1);
447 0         0 push @res, $res->[0];
448             }
449             #say "D:truncated CJK word: $word (".length($word)."), ".($width-$x)." -> $res->[0] (".length($res->[0]).") & $res->[1], remaining=$res->[3] (".length($res->[3]).")";
450 0         0 $word = $res->[3];
451 0         0 $wordw = _ta_mbswidth0($res->[3]);
452             } else {
453 16 100       27 push @res, "\e[0m" if $crcode;
454             }
455 16 50       29 push @res, " " x ($width-$x) if $pad;
456 16 50 66     43 push @res, " " if $ws_before && $optkts;
457 16         29 push @res, "\n";
458 16         21 $y++;
459 16         26 push @res, $crcode;
460 16         23 push @res, $sli;
461              
462 16 50       28 if ($sliw + $wordw <= $width) {
463 16         27 push @res, $word;
464 16         31 $x = $sliw + $wordw;
465 16         19 last;
466             } else {
467             # word still too long, break again
468 0         0 $x = $sliw;
469 0         0 $ws_before = 0;
470             }
471             }
472             }
473 120         265 $line_has_word++;
474             }
475              
476             }
477             } # for term
478 8 50 66     36 push @res, " " x ($width-$x) if $line_has_word && $pad;
479             }
480              
481 8 100       21 if ($opts->{return_stats}) {
482 1         11 return [join("", @res), {
483             max_word_width => $maxww,
484             min_word_width => $minww,
485             }];
486             } else {
487 7         167 return join("", @res);
488             }
489             }
490              
491             sub ta_wrap {
492 8     8 0 8722 _ta_wrap(0, @_);
493             }
494              
495             sub ta_mbwrap {
496 0     0 0 0 _ta_wrap(1, @_);
497             }
498              
499             sub _ta_pad {
500 7     7   17 my ($is_mb, $text, $width, $which, $padchar, $is_trunc) = @_;
501 7 100       16 if ($which) {
502 3         8 $which = substr($which, 0, 1);
503             } else {
504 4         7 $which = "r";
505             }
506 7   100     36 $padchar //= " ";
507              
508 7 50       19 my $w = $is_mb ? _ta_mbswidth0($text) : ta_length($text);
509 7 100 66     29 if ($is_trunc && $w > $width) {
510 1 50       9 my $res = $is_mb ?
511             ta_mbtrunc($text, $width, 1) : ta_trunc($text, $width, 1);
512 1         6 $text = $res->[0] . ($padchar x ($width-$res->[1]));
513             } else {
514 6 100       17 if ($which eq 'l') {
    100          
515 1         5 $text = ($padchar x ($width-$w)) . $text;
516             } elsif ($which eq 'c') {
517 1         7 my $n = int(($width-$w)/2);
518 1         7 $text = ($padchar x $n) . $text . ($padchar x ($width-$w-$n));
519             } else {
520 4 100       17 $text .= ($padchar x ($width-$w)) if $width > $w;
521             }
522             }
523 7         38 $text;
524             }
525              
526             sub ta_pad {
527 7     7 0 2785 _ta_pad(0, @_);
528             }
529              
530             sub ta_mbpad {
531 0     0 0 0 _ta_pad(1, @_);
532             }
533              
534             sub _ta_trunc {
535 16     16   44 my ($is_mb, $text, $width, $return_extra) = @_;
536              
537             # return_extra (undocumented): if set to 1, will return [truncated_text,
538             # visual width, length(chars) up to truncation point, rest of the text not
539             # included]
540              
541 16 50       50 my $w = $is_mb ? _ta_mbswidth0($text) : ta_length($text);
542 16 100       43 if ($w <= $width) {
543 2 50       14 return $return_extra ? [$text, $w, length($text), ''] : $text;
544             }
545 14         32 my @p = ta_split_codes_single($text);
546 14         28 my $res = '';
547 14         24 my $append = 1; # whether we should add more text
548 14         21 my $code4rest = '';
549 14         25 my $rest = '';
550 14         19 $w = 0;
551 14         19 my $c = 0;
552             #use Data::Dump; dd \@p;
553 14         58 while (my ($t, $ansi) = splice @p, 0, 2) {
554             #say "D: t=<$t>, \@p=", ~~@p, ", code4rest=<$code4rest>, rest=<$rest>";
555 45 100       81 if ($append) {
556 32 50       58 my $tw = $is_mb ? Text::WideChar::Util::mbswidth($t) : length($t);
557             #say "D: tw=$tw";
558 32 100       56 if ($w+$tw <= $width) {
559 22         38 $res .= $t;
560 22         27 $w += $tw;
561 22         33 $c += length($t);
562 22 100       48 $append = 0 if $w == $width;
563             #say "D:end1" unless $append;
564             } else {
565 10 50       42 my $tres = $is_mb ?
566             Text::WideChar::Util::mbtrunc($t, $width-$w, 1) :
567             [substr($t, 0, $width-$w), $width-$w, $width-$w];
568             #use Data::Dump; dd $tres;
569 10         21 $res .= $tres->[0];
570 10         21 $w += $tres->[1];
571 10         15 $c += $tres->[2];
572 10         18 $rest = substr($t, $tres->[2]);
573 10         23 $append = 0;
574             #say "D:end2";
575             }
576             } else {
577 13         20 $rest .= $t;
578             }
579 45 100       95 if (defined $ansi) {
580 39 100       64 if ($append) {
581 18 100       35 if ($ansi eq "\e[0m") {
582             #say "D:found color reset, resetting code4rest";
583 1         3 $c = length($ansi);
584 1         3 $code4rest = $ansi;
585             } else {
586 17         26 $c += length($ansi);
587 17         27 $code4rest .= $ansi;
588             }
589 18         51 $res .= $ansi;
590             } else {
591 21         28 $res .= $ansi;
592 21         55 $rest .= $ansi;
593             }
594             }
595             }
596              
597             # ta_trunc/ta_mbtrunc currently adds unpruned color codes at the end of
598             # truncated string. pruned meaning strings of color codes right before reset
599             # code is removed, e.g. \e[1m\e[30m...\e[0m becomes \e[0m. you might want to
600             # prune the result of trunc using _ta_prune_codes.
601              
602 14 100       28 if ($return_extra) {
603 10         37 return [$res, $w, $c, $code4rest . $rest];
604             } else {
605 4         19 return $res;
606             }
607             }
608              
609             sub _ta_prune_codes {
610 3     3   8 my $text = shift;
611 3         60 $text =~ s/($re_mult)\e\[0m/\e\[0m/g;
612 3         28 $text;
613             }
614              
615             sub ta_trunc {
616 10     10 0 3166 _ta_trunc(0, @_);
617             }
618              
619             sub ta_mbtrunc {
620 0     0 0 0 _ta_trunc(1, @_);
621             }
622              
623             sub _ta_highlight {
624 2     2   10 my ($is_all, $text, $needle, $color) = @_;
625              
626             # break into chunks
627 2         7 my (@chptext, @chcode, @chsavedc); # chunk plain texts, codes, saved codes
628 2         5 my $sc = "";
629 2         5 my $plaintext = "";
630 2         7 my @ch = ta_split_codes_single($text);
631 2         15 while (my ($pt, $c) = splice(@ch, 0, 2)) {
632 8         16 push @chptext , $pt;
633 8         17 push @chcode , $c;
634 8         13 push @chsavedc, $sc;
635 8         13 $plaintext .= $pt;
636 8 50 33     38 if (defined($c) && $c =~ /m\z/) {
637 8 100       27 if ($c eq "\e[0m") {
    50          
638 2         9 $sc = "";
639             } elsif ($c =~ /m\z/) {
640 6         20 $sc .= $c;
641             }
642             }
643             }
644             #use Data::Dump; print "\@chptext: "; dd \@chptext; print "\@chcode: "; dd \@chcode; print "\@chsavedc: "; dd \@chsavedc;
645              
646             # gather a list of needles to highlight, with their positions
647 2         4 my (@needle, @npos);
648 2 50       10 if (ref($needle) eq 'Regexp') {
649 0         0 my @m = $plaintext =~ /$needle/g;
650 0 0       0 return $text unless @m;
651 0         0 my $pos = 0;
652 0         0 while ($pos < length($plaintext)) {
653 0         0 my @pt;
654 0         0 for (@m) {
655 0         0 my $p = index($plaintext, $_, $pos);
656 0 0       0 push @pt, [$p, $_] if $p >= 0;
657             }
658 0 0       0 last unless @pt;
659 0         0 my $pmin = $pt[0][0];
660 0         0 my $t = $pt[0][1];
661 0         0 for (@pt) {
662 0 0 0     0 if ($pmin > $_->[0] ||
      0        
663             $pmin==$_->[0] && length($t) < length($_->[1])) {
664 0         0 $pmin = $_->[0];
665 0         0 $t = $_->[1];
666             }
667             }
668 0         0 push @needle, $t;
669 0         0 push @npos , $pmin;
670 0 0       0 last unless $is_all;
671 0         0 $pos = $pmin + length($t);
672             }
673             } else {
674 2         4 my $pos = 0;
675 2         5 while (1) {
676             #say "D:finding '$needle' in '$plaintext' from pos '$pos'";
677 4         9 my $p = index($plaintext, $needle, $pos);
678 4 100       14 last if $p < 0;
679 3         6 push @needle, $needle;
680 3         6 push @npos , $p;
681 3 100       11 last unless $is_all;
682 2         4 $pos = $p + length($needle);
683 2 50       8 last if $pos >= length($plaintext);
684             }
685 2 50       6 return $text unless @needle;
686             }
687             #use Data::Dump; print "\@needle: "; dd \@needle; print "\@npos: "; dd \@npos;
688              
689 2         6 my @res;
690 2         5 my $found = 1;
691 2         4 my $pos = 0;
692 2         4 my $i = 0;
693 2         3 my $curneed = shift @needle;
694 2         4 my $npos = shift @npos;
695             CHUNK:
696 2         4 while (1) {
697 11 100       22 last if $i >= @chptext;
698 9         18 my $pos2 = $pos+length($chptext[$i])-1;
699 9         14 my $npos2 = $npos+length($curneed)-1;
700             #say "D: chunk=[$chptext[$i]], npos=$npos, npos2=$npos2, pos=$pos, pos2=$pos2";
701 9 100 66     44 if ($pos > $npos2 || $pos2 < $npos || !$found) {
      66        
702             #say "D:inserting chunk: [$chptext[$i]]";
703             # no need to highlight
704 4         8 push @res, $chptext[$i];
705 4 50       14 push @res, $chcode[$i] if defined $chcode[$i];
706 4         21 goto L1;
707             }
708              
709             # there is chunk text at the left of needle?
710 5 100       26 if ($pos < $npos) {
711 3         9 my $pre = substr($chptext[$i], 0, $npos-$pos);
712             #say "D:inserting pre=[$pre]";
713 3         8 push @res, $pre;
714             }
715              
716 5         28 my $npart = substr($curneed,
717             max(0, $pos-$npos),
718             min($pos2, $npos2)-max($pos, $npos)+1);
719 5 50       12 if (length($npart)) {
720             #say "D:inserting npart=[$npart]";
721 5         13 push @res, $color, $npart;
722 5         11 push @res, "\e[0m";
723             #use Data::Dump; dd [$chsaved[$i], $chcode[$i]];
724 5         9 push @res, $chsavedc[$i];
725             }
726              
727             # is there chunk text at the right of needle?
728 5 100       12 if ($npos2 <= $pos2) {
729             #say "D:We have run past current needle [$curneed]";
730 3         10 my $post = substr($chptext[$i], $npos2-$pos+1);
731              
732 3 100       9 if (@needle) {
733 1         3 $curneed = shift @needle;
734 1         62 $npos = shift @npos;
735             #say "D:Finding the next needle ($curneed) at pos $npos";
736 1         4 $pos = $npos2+1;
737 1         4 $chptext[$i] = $post;
738 1         2 $found = 1;
739 1         4 redo CHUNK;
740             } else {
741             # we're done finding needle
742 2         3 $found = 0;
743             }
744              
745 2 50       6 if (!$found) {
746             #say "D:inserting post=[$post]";
747 2         6 push @res, $post;
748 2 50       6 push @res, $chcode[$i] if defined $chcode[$i];
749             }
750             }
751              
752             L1:
753 8         11 $pos = $pos2+1;
754 8         14 $i++;
755             }
756              
757 2         25 join "", @res;
758             }
759              
760             sub ta_highlight {
761 1     1 0 2955 _ta_highlight(0, @_);
762             }
763              
764             sub ta_highlight_all {
765 1     1 0 2876 _ta_highlight(1, @_);
766             }
767              
768             sub ta_add_color_resets {
769 1     1 0 2777 my (@text) = @_;
770              
771 1         4 my @res;
772 1         40 my $i = 0;
773 1         3 my $savedc = "";
774 1         3 for my $text (@text) {
775 4         6 $i++;
776 4 100 100     16 my $newt = $i > 1 && !$savedc ? "\e[0m" : $savedc;
777              
778             # break into chunks
779 4         10 my @ch = ta_split_codes_single($text);
780 4         17 while (my ($t, $c) = splice(@ch, 0, 2)) {
781 7         12 $newt .= $t;
782 7 100 66     32 if (defined($c) && $c =~ /m\z/) {
783 3         6 $newt .= $c;
784 3 100       13 if ($c eq "\e[0m") {
    50          
785 1         4 $savedc = "";
786             } elsif ($c =~ /m\z/) {
787 2         9 $savedc .= $c;
788             }
789             }
790             }
791              
792 4 100 66     16 $newt .= "\e[0m" if $savedc && $i < @text;
793 4         9 push @res, $newt;
794             }
795              
796 1         11 @res;
797             }
798              
799             sub _ta_substr {
800 3     3   6 my $is_mb = shift;
801 3         7 my $str = shift;
802 3         6 my $pos = shift;
803 3         4 my $len = shift;
804              
805 3         11 my $res1 = _ta_trunc($is_mb, $str, $pos, 1);
806 3         16 my $res2 = _ta_trunc($is_mb, $res1->[3], $len, 1);
807              
808 3 100       9 if (@_) {
809             # left + replacement + right
810 2         9 return _ta_prune_codes($res1->[0] . $_[0] . $res2->[3]);
811             } else {
812 1         4 return _ta_prune_codes($res2->[0]);
813             }
814             }
815              
816             sub ta_substr {
817 3     3 0 3454 _ta_substr(0, @_);
818             }
819              
820             sub ta_mbsubstr {
821 0     0 0   _ta_substr(1, @_);
822             }
823              
824              
825             1;
826             # ABSTRACT: Base for Text::ANSI::{Util,WideUtil}
827              
828             __END__