File Coverage

blib/lib/Progress/Any/Output/TermProgressBarColor.pm
Criterion Covered Total %
statement 110 160 68.7
branch 35 86 40.7
condition 17 41 41.4
subroutine 12 19 63.1
pod 3 4 75.0
total 177 310 57.1


line stmt bran cond sub pod time code
1             package Progress::Any::Output::TermProgressBarColor;
2              
3             our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
4             our $DATE = '2020-07-10'; # DATE
5             our $DIST = 'Progress-Any-Output-TermProgressBarColor'; # DIST
6             our $VERSION = '0.248'; # VERSION
7              
8 1     1   1863 use 5.010001;
  1         5  
9 1     1   6 use strict;
  1         2  
  1         21  
10 1     1   4 use warnings;
  1         2  
  1         29  
11              
12 1     1   599 use Color::ANSI::Util qw(ansifg ansibg);
  1         9942  
  1         637  
13             require Win32::Console::ANSI if $^O =~ /Win/;
14              
15             $|++;
16              
17             sub _patch {
18 2     2   5 my $out = shift;
19              
20 2 50       10 return if $out->{patch_handle1};
21              
22 2         567 require Monkey::Patch::Action;
23 2 50       4061 if (defined &{"Log::Any::Adapter::Screen::hook_before_log"}) {
  2 50       10  
24             $out->{patch_handle1} = Monkey::Patch::Action::patch_package(
25             'Log::Any::Adapter::Screen', 'hook_before_log', 'replace',
26             sub {
27             # we install a hook to clean up progress indicator first before
28             # we print log message to the screen.
29 0     0   0 $out->cleanup(1);
30 0         0 $Progress::Any::output_data{"$out"}{force_update} = 1;
31             }
32 0         0 );
33 2         8 } elsif (defined &{"Log::ger::Output::Screen::hook_before_log"}) {
34             $out->{patch_handle1} = Monkey::Patch::Action::patch_package(
35             'Log::ger::Output::Screen', 'hook_before_log', 'replace',
36             sub {
37             # we install a hook to clean up progress indicator first before
38             # we print log message to the screen.
39 0     0   0 $out->cleanup(1);
40 0         0 $Progress::Any::output_data{"$out"}{force_update} = 1;
41             }
42 0         0 );
43             }
44              
45 2 50       4 if (defined &{"Log::Any::Adapter::Screen::hook_after_log"}) {
  2 50       8  
46             $out->{patch_handle2} = Monkey::Patch::Action::patch_package(
47             'Log::Any::Adapter::Screen', 'hook_after_log', 'replace',
48             sub {
49 0     0   0 my ($self, $msg) = @_;
50              
51             # make sure we print a newline after logging so progress bar
52             # starts at column 1
53 0 0       0 print { $self->{_fh} } "\n" unless $msg =~ /\R\z/;
  0         0  
54              
55             # reset show_delay because we have displayed something
56 0 0       0 $out->keep_delay_showing if $out->{show_delay};
57              
58             # redisplay progress bar if were cleaned up
59 0 0       0 print { $self->{_fh} } $out->{_bar} if $out->{_bar};
  0         0  
60             }
61 0         0 );
62 2         8 } elsif (defined &{"Log::ger::Output::Screen::hook_after_log"}) {
63             $out->{patch_handle2} = Monkey::Patch::Action::patch_package(
64             'Log::ger::Output::Screen', 'hook_after_log', 'replace',
65             sub {
66 0     0   0 my ($ctx, $msg) = @_;
67             # make sure we print a newline after logging so progress bar
68             # starts at column 1
69 0 0       0 print { $ctx->{_fh} } "\n" unless $msg =~ /\R\z/;
  0         0  
70              
71             # reset show_delay because we have displayed something
72 0 0       0 $out->keep_delay_showing if $out->{show_delay};
73              
74             # redisplay progress bar if were cleaned up
75 0 0       0 print { $ctx->{_fh} } $out->{_bar} if $out->{_bar};
  0         0  
76             }
77 0         0 );
78             }
79             }
80              
81             sub _unpatch {
82 0     0   0 my $self = shift;
83 0         0 undef $self->{patch_handle1};
84 0         0 undef $self->{patch_handle2};
85             }
86              
87             sub _template_length {
88 2     2   11 require Progress::Any; # for $template_regex
89 1     1   8 no warnings 'once'; # $Progress::Any::template_regex
  1         2  
  1         1597  
90              
91 2         6 my ($self, $template) = @_;
92              
93 2         6 my $template_length = length($template);
94              
95 2         25 while ($template =~ /$Progress::Any::template_regex/g) {
96 8         34 my ($all, $width, $dot, $prec, $conv) =
97             ($1, $2, $3, $4, $5);
98              
99 8 50       19 if (defined $template_length) {
100              
101 8 100 66     46 if ($conv eq '%') {
    100          
    100          
    50          
    50          
    50          
102 2   50     10 $width //= 1;
103             } elsif ($conv eq 'b' || $conv eq 'B') {
104 2   33     9 $width //= $self->{_default_b_width};
105             } elsif ($conv eq 'p') {
106 2   50     8 $width //= 3;
107             } elsif ($conv eq 'e') {
108 0   0     0 $width //= -8;
109             } elsif ($conv eq 'r') {
110 0   0     0 $width //= -8;
111             } elsif ($conv eq 'R') {
112 2   50     8 $width //= -(8 + 1 + 7);
113             }
114              
115 8 50       18 if (defined $width) {
116 8         51 $template_length += abs($width) - length($all);
117             } else {
118 0         0 $template_length = undef;
119             }
120              
121             }
122             }
123              
124 2         8 $template_length;
125             }
126              
127             sub new {
128 2     2 1 4795 my ($class, %args0) = @_;
129              
130 2         5 my %args;
131              
132 2         5 $args{width} = delete($args0{width});
133 2 50       11 if (!defined($args{width})) {
134 2         5 my ($cols, $rows);
135 2 50       8 if ($ENV{COLUMNS}) {
    50          
136 0         0 $cols = $ENV{COLUMNS};
137 2         516 } elsif (eval { require Term::Size; 1 }) {
  2         613  
138 2         27 ($cols, $rows) = Term::Size::chars(*STDOUT{IO});
139             }
140 2   50     19 $cols //= 80;
141             # on windows if we print at rightmost column, cursor will move to the
142             # next line, so we try to avoid that
143 2 50       12 $args{width} = $^O =~ /Win/ ? $cols-1 : $cols;
144             }
145              
146 2         6 $args{fh} = delete($args0{fh});
147 2   100     9 $args{fh} //= \*STDERR;
148              
149 2         5 $args{show_delay} = delete($args0{show_delay});
150              
151 2         5 $args{freq} = delete($args0{freq});
152              
153 2         19 $args{wide} = delete($args0{wide});
154              
155 2         6 $args{rownum} = delete($args0{rownum});
156 2   50     9 $args{rownum} //= 0;
157              
158 2   50     12 $args{template} = delete($args0{template}) //
159             '%p%% [%B]%R';
160              
161 2 50       7 keys(%args0) and die "Unknown output parameter(s): ".
162             join(", ", keys(%args0));
163              
164 2         8 $args{_last_hide_time} = time();
165              
166 2         579 require Text::ANSI::Util;
167 2 50       5803 if ($args{wide}) {
168 0         0 require Text::ANSI::WideUtil;
169             }
170              
171 2         8 my $self = bless \%args, $class;
172              
173             # determine the default width for %b and %B
174             {
175 2         4 $self->{_default_b_width} = 0;
  2         11  
176 2         35 (my $template = $args{template}) =~ s!|!!g;
177 2   50     8 my $len = $self->_template_length($template) // 16;
178 2         7 $self->{_default_b_width} = $args{width} - $len;
179             }
180              
181             # render color in template
182 2 100       16 ($self->{_template} = $self->{template}) =~ s!|<(/)color>!$1 ? ansifg($1) : "\e[0m"!eg;
  16         8048  
183              
184 2         12 $self;
185             }
186              
187             sub _handle_unknown_conversion {
188 2     2   15 my %args = @_;
189              
190 2         6 my $conv = $args{conv};
191 2 50 33     12 return () unless $conv eq 'b' || $conv eq 'B';
192              
193 2         5 my $p = $args{indicator};
194 2         4 my $self = $args{self};
195              
196 2         7 my $tottgt = $p->total_target;
197 2         30 my $totpos = $p->total_pos;
198              
199 2         23 my $bar_bar = '';
200 2   33     11 my $bwidth = abs($args{width} // $self->{_default_b_width});
201              
202 2 50       6 if ($tottgt) {
203 2         7 my $bfilled = int($totpos / $tottgt * $bwidth);
204 2 50       6 $bfilled = $bwidth if $bfilled > $bwidth;
205 2         10 $bar_bar = ("=" x $bfilled) . (" " x ($bwidth-$bfilled));
206             } else {
207             # display 15% width of bar just moving right
208 0         0 my $bfilled = int(0.15 * $bwidth);
209 0 0       0 $bfilled = 1 if $bfilled < 1;
210 0         0 $self->{_x}++;
211 0 0       0 if ($self->{_x} > $bwidth-$bfilled) {
212 0         0 $self->{_x} = 0;
213             }
214             $bar_bar = (" " x $self->{_x}) . ("=" x $bfilled) .
215 0         0 (" " x ($bwidth-$self->{_x}-$bfilled));
216             }
217              
218 2         5 my $msg = $args{args}{message};
219 2 50 33     10 if ($conv eq 'B' && defined $msg) {
220 2 50       7 if ($msg =~ m!
221 0         0 require String::Elide::Parts;
222 0         0 $msg = String::Elide::Parts::elide($msg, $bwidth);
223             }
224 2         4 my $mwidth;
225 2 50       5 if ($self->{wide}) {
226 0         0 $msg = Text::ANSI::WideUtil::ta_mbtrunc($msg, $bwidth);
227 0         0 $mwidth = Text::ANSI::WideUtil::ta_mbswidth($msg);
228             } else {
229 2         8 $msg = Text::ANSI::Util::ta_trunc($msg, $bwidth);
230 2         43 $mwidth = Text::ANSI::Util::ta_length($msg);
231             }
232 2         18 $bar_bar = $msg . substr($bar_bar, $mwidth);
233             }
234              
235 2         12 return ("%s", $bar_bar);
236             }
237              
238             sub update {
239 2     2 1 3227 my ($self, %args) = @_;
240              
241 2 50 33     17 return unless $ENV{PROGRESS_TERM_BAR} // $ENV{PROGRESS} // (-t $self->{fh});
      33        
242              
243 2         5 my $now = time();
244              
245             # if there is show_delay, don't display until we've surpassed it
246 2 50       8 if (defined $self->{show_delay}) {
247 0 0       0 return if $now - $self->{show_delay} < $self->{_last_hide_time};
248             }
249              
250 2         10 $self->_patch;
251              
252 2         8 $self->cleanup;
253              
254 2         4 my $p = $args{indicator};
255 2         5 my $is_finished = $p->{state} eq 'finished';
256 2 50       6 if ($is_finished) {
257 0 0       0 if ($self->{_lastlen}) {
258 0         0 $self->{_last_hide_time} = $now;
259             }
260 0         0 return;
261             }
262              
263             my $bar = $p->fill_template(
264             {
265             template => $self->{_template},
266             handle_unknown_conversion => sub {
267 2     2   342 _handle_unknown_conversion(
268             self => $self,
269             @_,
270             );
271             },
272             },
273 2         21 %args,
274             );
275              
276 2         490 my $len = Text::ANSI::Util::ta_length($bar);
277             $self->{_bar} = join(
278             "",
279             "\n" x $self->{rownum},
280             $bar,
281             ("\b" x $len),
282 2 50       45 $self->{rownum} > 0 ? "\e[$self->{rownum}A" : "", # up N lines
283             );
284 2         5 print { $self->{fh} } $self->{_bar};
  2         98  
285 2         19 $self->{_lastlen} = $len;
286             }
287              
288             sub cleanup {
289 2     2 0 5 my ($self, $dont_reset_lastlen) = @_;
290              
291             # sometimes (e.g. when a subtask's target is undefined) we don't get
292             # state=finished at the end. but we need to cleanup anyway at the end of
293             # app, so this method is provided and will be called by e.g.
294             # Perinci::CmdLine
295              
296 2         6 my $ll = $self->{_lastlen};
297 2 50       6 return unless $ll;
298             my $clean_str = join(
299             "",
300             "\n" x $self->{rownum},
301             " " x $ll,
302             "\b" x $ll,
303 0 0         $self->{rownum} > 0 ? "\e[$self->{rownum}A" : "", # up N lines
304             );
305 0           print { $self->{fh} } $clean_str;
  0            
306 0 0         undef $self->{_lastlen} unless $dont_reset_lastlen;
307             }
308              
309             sub keep_delay_showing {
310 0     0 1   my $self = shift;
311              
312 0           $self->{_last_hide_time} = time();
313             }
314              
315             sub DESTROY {
316 0     0     my $self = shift;
317 0           $self->_unpatch;
318             }
319              
320             1;
321             # ABSTRACT: Output progress to terminal as color bar
322              
323             __END__