« back to all changes in this revision
Viewing changes to lib/Term/Sk.pm
- browse files at revision 12
- compare with another revision
- download diff
- download tarball
- view history from revision 12
- Committer: Package Import Robot
- Author(s): Salvatore Bonaccorso, gregor herrmann, Salvatore Bonaccorso
- Date: 2015-08-13 22:33:53 UTC
- mfrom: (1.1.10)
- Revision ID: package-import@ubuntu.com-20150813223353-vc56exhuqvltlelu
Tags: 0.17-1
* Team upload.
[ gregor herrmann ]
* debian/tests/control: add stanza for new runtime-deps-and-recommends
tests.
* Drop debian/tests/control, add Testsuite field to debian/control
instead.
[ Salvatore Bonaccorso ]
* Add debian/upstream/metadata
* Import upstream version 0.17
* Declare compliance with Debian policy 3.9.6
[ gregor herrmann ]
* debian/tests/control: add stanza for new runtime-deps-and-recommends
tests.
* Drop debian/tests/control, add Testsuite field to debian/control
instead.
[ Salvatore Bonaccorso ]
* Add debian/upstream/metadata
* Import upstream version 0.17
* Declare compliance with Debian policy 3.9.6
- files added:
- LICENSE
- debian/upstream
- files removed:
- .gitignore
- debian/tests
- files modified:
- Changes
added
removed
lib/Term/Sk.pm
1
package Term::Sk;
2
3
use strict;
4
use warnings;
5
6
use Time::HiRes qw( time );
7
use Fcntl qw(:seek);
8
9
require Exporter;
10
11
our @ISA = qw(Exporter);
12
13
our %EXPORT_TAGS = ( 'all' => [ qw(set_chunk_size set_bkup_size rem_backspace) ] );
14
15
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
16
17
our @EXPORT = qw();
18
19
our $VERSION = '0.16';
20
21
our $errcode = 0;
22
our $errmsg = '';
23
24
sub new {
25
shift;
26
my $self = {};
27
bless $self;
28
29
$errcode = 0;
30
$errmsg = '';
31
32
my %hash = (freq => 1, base => 0, target => 1_000, quiet => 0, test => 0, num => q{9_999});
33
%hash = (%hash, %{$_[1]}) if defined $_[1];
34
35
my $format = defined $_[0] ? $_[0] : '%8c';
36
37
$self->{base} = $hash{base};
38
$self->{target} = $hash{target};
39
$self->{quiet} = $hash{quiet};
40
$self->{test} = $hash{test};
41
$self->{format} = $format;
42
$self->{freq} = $hash{freq};
43
$self->{value} = $hash{base};
44
$self->{mock_tm} = $hash{mock_tm};
45
$self->{oldtext} = '';
46
$self->{line} = '';
47
$self->{pdisp} = '#';
48
$self->{commify} = $hash{commify};
49
$self->{token} = defined($hash{token}) ? ref($hash{token}) eq 'ARRAY' ? $hash{token} : [$hash{token}] : [];
50
51
unless (defined $self->{quiet}) {
52
$self->{quiet} = !-t STDOUT;
53
}
54
55
if ($hash{num} eq '9') {
56
$self->{sep} = '';
57
$self->{group} = 0;
58
}
59
else {
60
my ($sep, $group) = $hash{num} =~ m{\A 9 ([^\d\+\-]) (9+) \z}xms or do {
61
$errcode = 95;
62
$errmsg = qq{Can't parse num => '$hash{num}'};
63
die sprintf('Error-%04d: %s', $errcode, $errmsg);
64
};
65
$self->{sep} = $sep;
66
$self->{group} = length($group);
67
}
68
69
# Here we de-compose the format into $self->{action}
70
71
$self->{action} = [];
72
73
my $fmt = $format;
74
while ($fmt ne '') {
75
if ($fmt =~ m{^ ([^%]*) % (.*) $}xms) {
76
my ($literal, $portion) = ($1, $2);
77
unless ($portion =~ m{^ (\d*) ([a-zA-Z]) (.*) $}xms) {
78
$errcode = 100;
79
$errmsg = qq{Can't parse '%[<number>]<alpha>' from '%$portion', total line is '$format'};
80
die sprintf('Error-%04d: %s', $errcode, $errmsg);
81
}
82
83
my ($repeat, $disp_code, $remainder) = ($1, $2, $3);
84
85
if ($repeat eq '') { $repeat = 1; }
86
if ($repeat < 1) { $repeat = 1; }
87
88
unless ($disp_code eq 'b'
89
or $disp_code eq 'c'
90
or $disp_code eq 'd'
91
or $disp_code eq 'm'
92
or $disp_code eq 'p'
93
or $disp_code eq 'P'
94
or $disp_code eq 't'
95
or $disp_code eq 'k') {
96
$errcode = 110;
97
$errmsg = qq{Found invalid display-code ('$disp_code'), expected ('b', 'c', 'd', 'm', 'p', 'P' 't' or 'k') in '%$portion', total line is '$format'};
98
die sprintf('Error-%04d: %s', $errcode, $errmsg);
99
}
100
101
push @{$self->{action}}, {type => '*lit', len => length($literal), lit => $literal} if length($literal) > 0;
102
push @{$self->{action}}, {type => $disp_code, len => $repeat};
103
$fmt = $remainder;
104
}
105
else {
106
push @{$self->{action}}, {type => '*lit', len => length($fmt), lit => $fmt};
107
$fmt = '';
108
}
109
}
110
111
# End of format de-composition
112
113
$self->{tick} = 0;
114
$self->{out} = 0;
115
$self->{sec_begin} = $self->{mock_tm} ? $self->{mock_tm} : time;
116
$self->{sec_print} = 0;
117
118
$self->show;
119
120
return $self;
121
}
122
123
sub mock_time {
124
my $self = shift;
125
126
$self->{mock_tm} = $_[0];
127
}
128
129
sub whisper {
130
my $self = shift;
131
132
my $back = qq{\010} x length $self->{oldtext};
133
my $blank = q{ } x length $self->{oldtext};
134
135
$self->{line} = join('', $back, $blank, $back, @_, $self->{oldtext});
136
137
unless ($self->{test}) {
138
local $| = 1;
139
if ($self->{quiet}) {
140
print @_;
141
}
142
else {
143
print $self->{line};
144
}
145
}
146
}
147
148
sub get_line {
149
my $self = shift;
150
151
return $self->{line};
152
}
153
154
sub up { my $self = shift; $self->{value} += defined $_[0] ? $_[0] : 1; $self->show_maybe; }
155
sub down { my $self = shift; $self->{value} -= defined $_[0] ? $_[0] : 1; $self->show_maybe; }
156
sub close { my $self = shift; $self->{value} = undef; $self->show; }
157
158
sub ticks { my $self = shift; return $self->{tick} }
159
160
sub token {
161
my $self = shift;
162
my $tk = shift;
163
$self->{token} = ref($tk) eq 'ARRAY' ? $tk : [$tk];
164
$self->show;
165
}
166
167
sub tok_maybe {
168
my $self = shift;
169
my $tk = shift;
170
$self->{token} = ref($tk) eq 'ARRAY' ? $tk : [$tk];
171
$self->show_maybe;
172
}
173
174
sub DESTROY {
175
my $self = shift;
176
$self->close;
177
}
178
179
sub show_maybe {
180
my $self = shift;
181
182
$self->{line} = '';
183
184
my $sec_now = ($self->{mock_tm} ? $self->{mock_tm} : time) - $self->{sec_begin};
185
my $sec_prev = $self->{sec_print};
186
187
$self->{sec_print} = $sec_now;
188
$self->{tick}++;
189
190
if ($self->{freq} eq 's') {
191
if (int($sec_prev) != int($sec_now)) {
192
$self->show;
193
}
194
}
195
elsif ($self->{freq} eq 'd') {
196
if (int($sec_prev * 10) != int($sec_now * 10)) {
197
$self->show;
198
}
199
}
200
else {
201
unless ($self->{tick} % $self->{freq}) {
202
$self->show;
203
}
204
}
205
}
206
207
sub show {
208
my $self = shift;
209
$self->{out}++;
210
211
my $back = qq{\010} x length $self->{oldtext};
212
my $blank = q{ } x length $self->{oldtext};
213
214
my $text = '';
215
if (defined $self->{value}) {
216
217
# Here we compose a string based on $self->{action} (which, of course, is the previously de-composed format)
218
219
my $tok_ind = 0;
220
221
for my $act (@{$self->{action}}) {
222
my ($type, $lit, $len) = ($act->{type}, $act->{lit}, $act->{len});
223
224
if ($type eq '*lit') { # print (= append to $text) a simple literal
225
$text .= $lit;
226
next;
227
}
228
if ($type eq 't') { # print (= append to $text) time elapsed in format 'hh:mm:ss'
229
my $unit = int($self->{sec_print});
230
my $hour = int($unit / 3600);
231
my $min = int(($unit % 3600) / 60);
232
my $sec = $unit % 60;
233
my $stamp = sprintf '%02d:%02d:%02d', $hour, $min, $sec;
234
235
$stamp = substr($stamp, -$len) if length($stamp) > $len;
236
237
$text .= sprintf "%${len}.${len}s", $stamp;
238
next;
239
}
240
if ($type eq 'd') { # print (= append to $text) a revolving dash in format '/-\|'
241
$text .= substr('/-\|', $self->{out} % 4, 1) x $len;
242
next;
243
}
244
if ($type eq 'b') { # print (= append to $text) progress indicator format '#####_____'
245
my $progress = $self->{target} == $self->{base} ? 0 :
246
int ($len * ($self->{value} - $self->{base}) / ($self->{target} - $self->{base}) + 0.5);
247
if ($progress < 0) { $progress = 0 }
248
elsif ($progress > $len) { $progress = $len }
249
$text .= $self->{pdisp} x $progress.'_' x ($len - $progress);
250
next;
251
}
252
if ($type eq 'p') { # print (= append to $text) progress in percentage format '999%'
253
my $percent = $self->{target} == $self->{base} ? 0 :
254
100 * ($self->{value} - $self->{base}) / ($self->{target} - $self->{base});
255
$text .= sprintf "%${len}.${len}s", sprintf("%.0f%%", $percent);
256
next;
257
}
258
if ($type eq 'P') { # print (= append to $text) literally '%' characters
259
$text .= '%' x $len;
260
next;
261
}
262
if ($type eq 'c') { # print (= append to $text) actual counter value (commified)
263
$text .= sprintf "%${len}s", commify($self->{commify}, $self->{value}, $self->{sep}, $self->{group});
264
next;
265
}
266
if ($type eq 'm') { # print (= append to $text) target (commified)
267
$text .= sprintf "%${len}s", commify($self->{commify}, $self->{target}, $self->{sep}, $self->{group});
268
next;
269
}
270
if ($type eq 'k') { # print (= append to $text) token
271
$text .= sprintf "%-${len}s", $self->{token}[$tok_ind];
272
$tok_ind++;
273
next;
274
}
275
# default: do nothing, in the (impossible) event that $type is none of '*lit', 't', 'b', 'p', 'P', 'c', 'm' or 'k'
276
}
277
278
# End of string composition
279
}
280
281
$self->{line} = join('', $back, $blank, $back, $text);
282
283
unless ($self->{test} or $self->{quiet}) {
284
local $| = 1;
285
print $self->{line};
286
}
287
288
$self->{oldtext} = $text;
289
}
290
291
sub commify {
292
my $com = shift;
293
if ($com) { return $com->($_[0]); }
294
295
local $_ = shift;
296
my ($sep, $group) = @_;
297
298
if ($group > 0) {
299
my $len = length($_);
300
for my $i (1..$len) {
301
last unless s/^([-+]?\d+)(\d{$group})/$1$sep$2/;
302
}
303
}
304
return $_;
305
}
306
307
my $chunk_size = 10000;
308
my $bkup_size = 80;
309
310
# Decision by Klaus Eichner, 31-MAY-2011:
311
# ---------------------------------------
312
# Make subs log_info(), set_chunk_size() and set_bkup_size() effectively dummy operations (i.e. they
313
# don't have any effect whatsoever)
314
315
sub log_info { }
316
sub set_chunk_size { }
317
sub set_bkup_size { }
318
319
sub rem_backspace {
320
my ($fname) = @_;
321
322
open my $ifh, '<', $fname or die "Error-0200: Can't open < '$fname' because $!";
323
open my $tfh, '+>', undef or die "Error-0210: Can't open +> undef (tempfile) because $!";
324
325
my $out_buf = '';
326
327
while (read($ifh, my $inp_buf, $chunk_size)) {
328
$out_buf .= $inp_buf;
329
330
# here we are removing the backspaces:
331
while ($out_buf =~ m{\010+}xms) {
332
my $pos_left = $-[0] * 2 - $+[0];
333
if ($pos_left < 0) {
334
$pos_left = 0;
335
}
336
$out_buf = substr($out_buf, 0, $pos_left).substr($out_buf, $+[0]);
337
}
338
339
if (length($out_buf) > $bkup_size) {
340
print {$tfh} substr($out_buf, 0, -$bkup_size);
341
$out_buf = substr($out_buf, -$bkup_size);
342
}
343
}
344
345
CORE::close $ifh; # We need to employ CORE::close because there is already another close subroutine defined in the current namespace "Term::Sk"
346
347
print {$tfh} $out_buf;
348
349
# Now copy back temp-file to original file:
350
351
seek $tfh, 0, SEEK_SET or die "Error-0220: Can't seek tempfile to 0 because $!";
352
open my $ofh, '>', $fname or die "Error-0230: Can't open > '$fname' because $!";
353
354
while (read($tfh, my $buf, $chunk_size)) { print {$ofh} $buf; }
355
356
CORE::close $ofh;
357
CORE::close $tfh;
358
}
359
360
1;
361
362
__END__
363
364
=head1 NAME
365
366
Term::Sk - Perl extension for displaying a progress indicator on a terminal.
367
368
=head1 SYNOPSIS
369
370
use Term::Sk;
371
372
my $ctr = Term::Sk->new('%d Elapsed: %8t %21b %4p %2d (%8c of %11m)',
373
{quiet => 0, freq => 10, base => 0, target => 100, pdisp => '!'});
374
375
$ctr->up for (1..100);
376
377
$ctr->down for (1..100);
378
379
$ctr->whisper('abc');
380
381
my last_line = $ctr->get_line;
382
383
$ctr->close;
384
385
print "Number of ticks: ", $ctr->ticks, "\n";
386
387
=head1 EXAMPLES
388
389
Term::Sk is a class to implement a progress indicator ("Sk" is a short form for "Show Key"). This is used to provide immediate feedback for
390
long running processes.
391
392
A sample code fragment that uses Term::Sk:
393
394
use Term::Sk;
395
396
print qq{This is a test of "Term::Sk"\n\n};
397
398
my $target = 2_845;
399
my $format = '%2d Elapsed: %8t %21b %4p %2d (%8c of %11m)';
400
401
my $ctr = Term::Sk->new($format,
402
{freq => 10, base => 0, target => $target, pdisp => '!'});
403
404
for (1..$target) {
405
$ctr->up;
406
do_something();
407
}
408
409
$ctr->close;
410
411
sub do_something {
412
my $test = 0;
413
for my $i (0..10_000) {
414
$test += sin($i) * cos($i);
415
}
416
}
417
418
Another example that counts upwards:
419
420
use Term::Sk;
421
422
my $format = '%21b %4p';
423
424
my $ctr = Term::Sk->new($format, {freq => 's', base => 0, target => 70});
425
426
for (1..10) {
427
$ctr->up(7);
428
sleep 1;
429
}
430
431
$ctr->close;
432
433
At any time, after Term::Sk->new(), you can query the number of ticks (i.e. number of calls to
434
$ctr->up or $ctr->down) using the method 'ticks':
435
436
use Term::Sk;
437
438
my $ctr = Term::Sk->new('%6c', {freq => 's', base => 0, target => 70});
439
440
for (1..4288) {
441
$ctr->up;
442
}
443
444
$ctr->close;
445
446
print "Number of ticks: ", $ctr->ticks, "\n";
447
448
This example uses a simple progress bar in quiet mode (nothing is printed to STDOUT), but
449
instead, the content of what would have been printed can now be extracted using the get_line() method:
450
451
use Term::Sk;
452
453
my $format = 'Ctr %4c';
454
455
my $ctr = Term::Sk->new($format, {freq => 2, base => 0, target => 10, quiet => 1});
456
457
my $line = $ctr->get_line;
458
$line =~ s/\010/</g;
459
print "This is what would have been printed upon new(): [$line]\n";
460
461
for my $i (1..10) {
462
$ctr->up;
463
464
$line = $ctr->get_line;
465
$line =~ s/\010/</g;
466
print "This is what would have been printed upon $i. call to up(): [$line]\n";
467
}
468
469
$ctr->close;
470
471
$line = $ctr->get_line;
472
$line =~ s/\010/</g;
473
print "This is what would have been printed upon close(): [$line]\n";
474
475
Here are some examples that show different values for option {num => ...}
476
477
my $format = 'act %c max %m';
478
479
my $ctr1 = Term::Sk->new($format, {base => 1234567, target => 2345678});
480
# The following numbers are shown: act 1_234_567 max 2_345_678
481
482
my $ctr2 = Term::Sk->new($format, {base => 1234567, target => 2345678, num => q{9,999}});
483
# The following numbers are shown: act 1,234,567 max 2,345,678
484
485
my $ctr3 = Term::Sk->new($format, {base => 1234567, target => 2345678, num => q{9'99}});
486
# The following numbers are shown: act 1'23'45'67 max 2'34'56'78
487
488
my $ctr4 = Term::Sk->new($format, {base => 1234567, target => 2345678, num => q{9}});
489
# The following numbers are shown: act 1234567 max 2345678
490
491
my $ctr5 = Term::Sk->new($format, {base => 1234567, target => 2345678,
492
commify => sub{ join '!', split m{}xms, $_[0]; }});
493
# The following numbers are shown: act 1!2!3!4!5!6!7 max 2!3!4!5!6!7!8
494
495
=head1 DESCRIPTION
496
497
=head2 Format strings
498
499
The first parameter to new() is the format string which contains the following
500
special characters:
501
502
=over
503
504
=item characters '%d'
505
506
a revolving dash, format '/-\|'
507
508
=item characters '%t'
509
510
time elapsed, format 'hh:mm:ss'
511
512
=item characters '%b'
513
514
progress bar, format '#####_____'
515
516
=item characters '%p'
517
518
Progress in percentage, format '999%'
519
520
=item characters '%c'
521
522
Actual counter value (commified by '_'), format '99_999_999'
523
524
=item characters '%m'
525
526
Target maximum value (commified by '_'), format '99_999_999'
527
528
=item characters '%k'
529
530
Token which updates its value before being displayed. An example use
531
of this would be a loop wherein every step of the loop could be
532
identified by a particular string. For example:
533
534
my $ctr = Term::Sk->new('Processing %k counter %c',
535
{base => 0, token => 'Albania'});
536
foreach my $country (@list_of_european_nations) {
537
$ctr->token($country);
538
for (1..500) {
539
$ctr->up;
540
## do something...
541
}
542
};
543
$ctr->close;
544
545
You can also have more than one token on a single line. Here is an example:
546
547
my $ctr = Term::Sk->new('Processing %k Region %k counter %c',
548
{base => 0, token => ['Albania', 'South']});
549
foreach my $country (@list_of_european_nations) {
550
$ctr->token([$country, 'North']);
551
for (1..500) {
552
$ctr->up;
553
## do something...
554
}
555
};
556
$ctr->close;
557
558
The C<token> method is used to update the token value immediately on the screen.
559
560
The C<tok_maybe> method is used to set the token value, but the screen is not refreshed immediately.
561
562
If '%k' is used, then the counter must be instantiated with an initial value for the token.
563
564
=item characters '%P'
565
566
The '%' character itself
567
568
=back
569
570
=head2 Options
571
572
The second parameter are the following options:
573
574
=over
575
576
=item option {freq => 999}
577
578
This option sets the refresh-frequency on STDOUT to every 999 up() or
579
down() calls. If {freq => 999} is not specified at all, then the
580
refresh-frequency is set by default to every up() or down() call.
581
582
=item option {freq => 's'}
583
584
This is a special case whereby the refresh-frequency on STDOUT is set to every
585
second.
586
587
=item option {freq => 'd'}
588
589
This is a special case whereby the refresh-frequency on STDOUT is set to every
590
1/10th of a second.
591
592
=item option {base => 0}
593
594
This specifies the base value from which to count. The default is 0
595
596
=item option {target => 10_000}
597
598
This specifies the maximum value to which to count. The default is 10_000.
599
600
=item option {pdisp => '!'}
601
602
This option (with the exclamation mark) is obsolete and has no effect whatsoever. The
603
progressbar will always be displayed using the hash-symbol "#".
604
605
=item option {quiet => 1}
606
607
This option disables most printing to STDOUT, but the content of the would be printed
608
line is still available using the method get_line(). The whisper-method, however,
609
still shows its output.
610
611
The default is in fact {quiet => !-t STDOUT}
612
613
=item option {num => '9_999'}
614
615
This option configures the output number format for the counters.
616
617
=item option {commify => sub{...}}
618
619
This option allows one to register a subroutine that formats the counters.
620
621
=item option {test => 1}
622
623
This option is used for testing purposes only, it disables all printing to STDOUT, even
624
the whisper shows no output. But again, the content of the would be printed line is
625
still available using the method get_line().
626
627
=back
628
629
=head2 Processing
630
631
The new() method immediately displays the initial values on screen. From now on,
632
nothing must be printed to STDOUT and/or STDERR. However, you can write to STDOUT during
633
the operation using the method whisper().
634
635
We can either count upwards, $ctr->up, or downwards, $ctr->down. Everytime we do so, the
636
value is either incremented or decremented and the new value is replaced on STDOUT. We should
637
do so regularly during the process. Both methods, $ctr->up(99) and $ctr->down(99) can take an
638
optional argument, in which case the value is incremented/decremented by the specified amount.
639
640
When our process has finished, we must close the counter ($ctr->close). By doing so, the last
641
displayed value is removed from STDOUT, as if nothing had happened. Now we are allowed to print
642
again to STDOUT and/or STDERR.
643
644
=head2 Post hoc transformation
645
646
In some cases it makes sense to redirected STDOUT to a flat file. In this case, the backspace
647
characters remain in the flat file.
648
649
There is a function "rem_backspace()" that removes the backspaces (including the characters that
650
they are supposed to remove) from a redirected file.
651
652
Here is a simplified example:
653
654
use Term::Sk qw(rem_backspace);
655
656
my $flatfile = "Test hijabc\010\010\010xyzklmttt\010\010yzz";
657
658
printf "before (len=%3d): '%s'\n", length($flatfile), $flatfile;
659
660
rem_backspace(\$flatfile);
661
662
printf "after (len=%3d): '%s'\n", length($flatfile), $flatfile;
663
664
=head1 AUTHOR
665
666
Klaus Eichner, January 2008
667
668
=head1 COPYRIGHT AND LICENSE
669
670
Copyright (C) 2008-2011 by Klaus Eichner
671
672
This library is free software; you can redistribute it and/or modify
673
it under the same terms as Perl itself.
674
675
=cut
1
package Term::Sk;
2
$Term::Sk::VERSION = '0.17';
3
use strict;
4
use warnings;
5
6
use Time::HiRes qw( time );
7
use Fcntl qw(:seek);
8
9
require Exporter;
10
11
our @ISA = qw(Exporter);
12
our %EXPORT_TAGS = ( 'all' => [ qw(set_chunk_size set_bkup_size rem_backspace) ] );
13
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
14
our @EXPORT = qw();
15
16
our $errcode = 0;
17
our $errmsg = '';
18
19
sub new {
20
shift;
21
my $self = {};
22
bless $self;
23
24
$errcode = 0;
25
$errmsg = '';
26
27
my %hash = (freq => 1, base => 0, target => 1_000, quiet => 0, test => 0, num => q{9_999});
28
%hash = (%hash, %{$_[1]}) if defined $_[1];
29
30
my $format = defined $_[0] ? $_[0] : '%8c';
31
32
$self->{base} = $hash{base};
33
$self->{target} = $hash{target};
34
$self->{quiet} = $hash{quiet};
35
$self->{test} = $hash{test};
36
$self->{format} = $format;
37
$self->{freq} = $hash{freq};
38
$self->{value} = $hash{base};
39
$self->{mock_tm} = $hash{mock_tm};
40
$self->{oldtext} = '';
41
$self->{line} = '';
42
$self->{pdisp} = '#';
43
$self->{commify} = $hash{commify};
44
$self->{token} = defined($hash{token}) ? ref($hash{token}) eq 'ARRAY' ? $hash{token} : [$hash{token}] : [];
45
46
unless (defined $self->{quiet}) {
47
$self->{quiet} = !-t STDOUT;
48
}
49
50
if ($hash{num} eq '9') {
51
$self->{sep} = '';
52
$self->{group} = 0;
53
}
54
else {
55
my ($sep, $group) = $hash{num} =~ m{\A 9 ([^\d\+\-]) (9+) \z}xms or do {
56
$errcode = 95;
57
$errmsg = qq{Can't parse num => '$hash{num}'};
58
die sprintf('Error-%04d: %s', $errcode, $errmsg);
59
};
60
$self->{sep} = $sep;
61
$self->{group} = length($group);
62
}
63
64
# Here we de-compose the format into $self->{action}
65
66
$self->{action} = [];
67
68
my $fmt = $format;
69
while ($fmt ne '') {
70
if ($fmt =~ m{^ ([^%]*) % (.*) $}xms) {
71
my ($literal, $portion) = ($1, $2);
72
unless ($portion =~ m{^ (\d*) ([a-zA-Z]) (.*) $}xms) {
73
$errcode = 100;
74
$errmsg = qq{Can't parse '%[<number>]<alpha>' from '%$portion', total line is '$format'};
75
die sprintf('Error-%04d: %s', $errcode, $errmsg);
76
}
77
78
my ($repeat, $disp_code, $remainder) = ($1, $2, $3);
79
80
if ($repeat eq '') { $repeat = 1; }
81
if ($repeat < 1) { $repeat = 1; }
82
83
unless ($disp_code eq 'b'
84
or $disp_code eq 'c'
85
or $disp_code eq 'd'
86
or $disp_code eq 'm'
87
or $disp_code eq 'p'
88
or $disp_code eq 'P'
89
or $disp_code eq 't'
90
or $disp_code eq 'k') {
91
$errcode = 110;
92
$errmsg = qq{Found invalid display-code ('$disp_code'), expected ('b', 'c', 'd', 'm', 'p', 'P' 't' or 'k') in '%$portion', total line is '$format'};
93
die sprintf('Error-%04d: %s', $errcode, $errmsg);
94
}
95
96
push @{$self->{action}}, {type => '*lit', len => length($literal), lit => $literal} if length($literal) > 0;
97
push @{$self->{action}}, {type => $disp_code, len => $repeat};
98
$fmt = $remainder;
99
}
100
else {
101
push @{$self->{action}}, {type => '*lit', len => length($fmt), lit => $fmt};
102
$fmt = '';
103
}
104
}
105
106
# End of format de-composition
107
108
$self->{tick} = 0;
109
$self->{out} = 0;
110
$self->{sec_begin} = $self->{mock_tm} ? $self->{mock_tm} : time;
111
$self->{sec_print} = 0;
112
113
$self->show;
114
115
return $self;
116
}
117
118
sub mock_time {
119
my $self = shift;
120
121
$self->{mock_tm} = $_[0];
122
}
123
124
sub whisper {
125
my $self = shift;
126
127
my $back = qq{\010} x length $self->{oldtext};
128
my $blank = q{ } x length $self->{oldtext};
129
130
$self->{line} = join('', $back, $blank, $back, @_, $self->{oldtext});
131
132
unless ($self->{test}) {
133
local $| = 1;
134
if ($self->{quiet}) {
135
print @_;
136
}
137
else {
138
print $self->{line};
139
}
140
}
141
}
142
143
sub get_line {
144
my $self = shift;
145
146
return $self->{line};
147
}
148
149
sub up { my $self = shift; $self->{value} += defined $_[0] ? $_[0] : 1; $self->show_maybe; }
150
sub down { my $self = shift; $self->{value} -= defined $_[0] ? $_[0] : 1; $self->show_maybe; }
151
sub close { my $self = shift; $self->{value} = undef; $self->show; }
152
153
sub ticks { my $self = shift; return $self->{tick} }
154
155
sub token {
156
my $self = shift;
157
my $tk = shift;
158
$self->{token} = ref($tk) eq 'ARRAY' ? $tk : [$tk];
159
$self->show;
160
}
161
162
sub tok_maybe {
163
my $self = shift;
164
my $tk = shift;
165
$self->{token} = ref($tk) eq 'ARRAY' ? $tk : [$tk];
166
$self->show_maybe;
167
}
168
169
sub DESTROY {
170
my $self = shift;
171
$self->close;
172
}
173
174
sub show_maybe {
175
my $self = shift;
176
177
$self->{line} = '';
178
179
my $sec_now = ($self->{mock_tm} ? $self->{mock_tm} : time) - $self->{sec_begin};
180
my $sec_prev = $self->{sec_print};
181
182
$self->{sec_print} = $sec_now;
183
$self->{tick}++;
184
185
if ($self->{freq} eq 's') {
186
if (int($sec_prev) != int($sec_now)) {
187
$self->show;
188
}
189
}
190
elsif ($self->{freq} eq 'd') {
191
if (int($sec_prev * 10) != int($sec_now * 10)) {
192
$self->show;
193
}
194
}
195
else {
196
unless ($self->{tick} % $self->{freq}) {
197
$self->show;
198
}
199
}
200
}
201
202
sub show {
203
my $self = shift;
204
$self->{out}++;
205
206
my $back = qq{\010} x length $self->{oldtext};
207
my $blank = q{ } x length $self->{oldtext};
208
209
my $text = '';
210
if (defined $self->{value}) {
211
212
# Here we compose a string based on $self->{action} (which, of course, is the previously de-composed format)
213
214
my $tok_ind = 0;
215
216
for my $act (@{$self->{action}}) {
217
my ($type, $lit, $len) = ($act->{type}, $act->{lit}, $act->{len});
218
219
if ($type eq '*lit') { # print (= append to $text) a simple literal
220
$text .= $lit;
221
next;
222
}
223
if ($type eq 't') { # print (= append to $text) time elapsed in format 'hh:mm:ss'
224
my $unit = int($self->{sec_print});
225
my $hour = int($unit / 3600);
226
my $min = int(($unit % 3600) / 60);
227
my $sec = $unit % 60;
228
my $stamp = sprintf '%02d:%02d:%02d', $hour, $min, $sec;
229
230
$stamp = substr($stamp, -$len) if length($stamp) > $len;
231
232
$text .= sprintf "%${len}.${len}s", $stamp;
233
next;
234
}
235
if ($type eq 'd') { # print (= append to $text) a revolving dash in format '/-\|'
236
$text .= substr('/-\|', $self->{out} % 4, 1) x $len;
237
next;
238
}
239
if ($type eq 'b') { # print (= append to $text) progress indicator format '#####_____'
240
my $progress = $self->{target} == $self->{base} ? 0 :
241
int ($len * ($self->{value} - $self->{base}) / ($self->{target} - $self->{base}) + 0.5);
242
if ($progress < 0) { $progress = 0 }
243
elsif ($progress > $len) { $progress = $len }
244
$text .= $self->{pdisp} x $progress.'_' x ($len - $progress);
245
next;
246
}
247
if ($type eq 'p') { # print (= append to $text) progress in percentage format '999%'
248
my $percent = $self->{target} == $self->{base} ? 0 :
249
100 * ($self->{value} - $self->{base}) / ($self->{target} - $self->{base});
250
$text .= sprintf "%${len}.${len}s", sprintf("%.0f%%", $percent);
251
next;
252
}
253
if ($type eq 'P') { # print (= append to $text) literally '%' characters
254
$text .= '%' x $len;
255
next;
256
}
257
if ($type eq 'c') { # print (= append to $text) actual counter value (commified)
258
$text .= sprintf "%${len}s", commify($self->{commify}, $self->{value}, $self->{sep}, $self->{group});
259
next;
260
}
261
if ($type eq 'm') { # print (= append to $text) target (commified)
262
$text .= sprintf "%${len}s", commify($self->{commify}, $self->{target}, $self->{sep}, $self->{group});
263
next;
264
}
265
if ($type eq 'k') { # print (= append to $text) token
266
$text .= sprintf "%-${len}s", $self->{token}[$tok_ind];
267
$tok_ind++;
268
next;
269
}
270
# default: do nothing, in the (impossible) event that $type is none of '*lit', 't', 'b', 'p', 'P', 'c', 'm' or 'k'
271
}
272
273
# End of string composition
274
}
275
276
$self->{line} = join('', $back, $blank, $back, $text);
277
278
unless ($self->{test} or $self->{quiet}) {
279
local $| = 1;
280
print $self->{line};
281
}
282
283
$self->{oldtext} = $text;
284
}
285
286
sub commify {
287
my $com = shift;
288
if ($com) { return $com->($_[0]); }
289
290
local $_ = shift;
291
my ($sep, $group) = @_;
292
293
if ($group > 0) {
294
my $len = length($_);
295
for my $i (1..$len) {
296
last unless s/^([-+]?\d+)(\d{$group})/$1$sep$2/;
297
}
298
}
299
return $_;
300
}
301
302
my $chunk_size = 10000;
303
my $bkup_size = 80;
304
305
# Decision by Klaus Eichner, 31-MAY-2011:
306
# ---------------------------------------
307
# Make subs log_info(), set_chunk_size() and set_bkup_size() effectively dummy operations (i.e. they
308
# don't have any effect whatsoever)
309
310
sub log_info { }
311
sub set_chunk_size { }
312
sub set_bkup_size { }
313
314
sub rem_backspace {
315
my ($fname) = @_;
316
317
open my $ifh, '<', $fname or die "Error-0200: Can't open < '$fname' because $!";
318
open my $tfh, '+>', undef or die "Error-0210: Can't open +> undef (tempfile) because $!";
319
320
my $out_buf = '';
321
322
while (read($ifh, my $inp_buf, $chunk_size)) {
323
$out_buf .= $inp_buf;
324
325
# here we are removing the backspaces:
326
while ($out_buf =~ m{\010+}xms) {
327
my $pos_left = $-[0] * 2 - $+[0];
328
if ($pos_left < 0) {
329
$pos_left = 0;
330
}
331
$out_buf = substr($out_buf, 0, $pos_left).substr($out_buf, $+[0]);
332
}
333
334
if (length($out_buf) > $bkup_size) {
335
print {$tfh} substr($out_buf, 0, -$bkup_size);
336
$out_buf = substr($out_buf, -$bkup_size);
337
}
338
}
339
340
CORE::close $ifh; # We need to employ CORE::close because there is already another close subroutine defined in the current namespace "Term::Sk"
341
342
print {$tfh} $out_buf;
343
344
# Now copy back temp-file to original file:
345
346
seek $tfh, 0, SEEK_SET or die "Error-0220: Can't seek tempfile to 0 because $!";
347
open my $ofh, '>', $fname or die "Error-0230: Can't open > '$fname' because $!";
348
349
while (read($tfh, my $buf, $chunk_size)) { print {$ofh} $buf; }
350
351
CORE::close $ofh;
352
CORE::close $tfh;
353
}
354
355
1;
356
357
__END__
358
359
=head1 NAME
360
361
Term::Sk - Perl extension for displaying a progress indicator on a terminal.
362
363
=head1 SYNOPSIS
364
365
use Term::Sk;
366
367
my $ctr = Term::Sk->new('%d Elapsed: %8t %21b %4p %2d (%8c of %11m)',
368
{quiet => 0, freq => 10, base => 0, target => 100, pdisp => '!'});
369
370
$ctr->up for (1..100);
371
372
$ctr->down for (1..100);
373
374
$ctr->whisper('abc');
375
376
my last_line = $ctr->get_line;
377
378
$ctr->close;
379
380
print "Number of ticks: ", $ctr->ticks, "\n";
381
382
=head1 EXAMPLES
383
384
Term::Sk is a class to implement a progress indicator ("Sk" is a short form for "Show Key"). This is used to provide immediate feedback for
385
long running processes.
386
387
A sample code fragment that uses Term::Sk:
388
389
use Term::Sk;
390
391
print qq{This is a test of "Term::Sk"\n\n};
392
393
my $target = 2_845;
394
my $format = '%2d Elapsed: %8t %21b %4p %2d (%8c of %11m)';
395
396
my $ctr = Term::Sk->new($format,
397
{freq => 10, base => 0, target => $target, pdisp => '!'});
398
399
for (1..$target) {
400
$ctr->up;
401
do_something();
402
}
403
404
$ctr->close;
405
406
sub do_something {
407
my $test = 0;
408
for my $i (0..10_000) {
409
$test += sin($i) * cos($i);
410
}
411
}
412
413
Another example that counts upwards:
414
415
use Term::Sk;
416
417
my $format = '%21b %4p';
418
419
my $ctr = Term::Sk->new($format, {freq => 's', base => 0, target => 70});
420
421
for (1..10) {
422
$ctr->up(7);
423
sleep 1;
424
}
425
426
$ctr->close;
427
428
At any time, after Term::Sk->new(), you can query the number of ticks (i.e. number of calls to
429
$ctr->up or $ctr->down) using the method 'ticks':
430
431
use Term::Sk;
432
433
my $ctr = Term::Sk->new('%6c', {freq => 's', base => 0, target => 70});
434
435
for (1..4288) {
436
$ctr->up;
437
}
438
439
$ctr->close;
440
441
print "Number of ticks: ", $ctr->ticks, "\n";
442
443
This example uses a simple progress bar in quiet mode (nothing is printed to STDOUT), but
444
instead, the content of what would have been printed can now be extracted using the get_line() method:
445
446
use Term::Sk;
447
448
my $format = 'Ctr %4c';
449
450
my $ctr = Term::Sk->new($format, {freq => 2, base => 0, target => 10, quiet => 1});
451
452
my $line = $ctr->get_line;
453
$line =~ s/\010/</g;
454
print "This is what would have been printed upon new(): [$line]\n";
455
456
for my $i (1..10) {
457
$ctr->up;
458
459
$line = $ctr->get_line;
460
$line =~ s/\010/</g;
461
print "This is what would have been printed upon $i. call to up(): [$line]\n";
462
}
463
464
$ctr->close;
465
466
$line = $ctr->get_line;
467
$line =~ s/\010/</g;
468
print "This is what would have been printed upon close(): [$line]\n";
469
470
Here are some examples that show different values for option {num => ...}
471
472
my $format = 'act %c max %m';
473
474
my $ctr1 = Term::Sk->new($format, {base => 1234567, target => 2345678});
475
# The following numbers are shown: act 1_234_567 max 2_345_678
476
477
my $ctr2 = Term::Sk->new($format, {base => 1234567, target => 2345678, num => q{9,999}});
478
# The following numbers are shown: act 1,234,567 max 2,345,678
479
480
my $ctr3 = Term::Sk->new($format, {base => 1234567, target => 2345678, num => q{9'99}});
481
# The following numbers are shown: act 1'23'45'67 max 2'34'56'78
482
483
my $ctr4 = Term::Sk->new($format, {base => 1234567, target => 2345678, num => q{9}});
484
# The following numbers are shown: act 1234567 max 2345678
485
486
my $ctr5 = Term::Sk->new($format, {base => 1234567, target => 2345678,
487
commify => sub{ join '!', split m{}xms, $_[0]; }});
488
# The following numbers are shown: act 1!2!3!4!5!6!7 max 2!3!4!5!6!7!8
489
490
=head1 DESCRIPTION
491
492
=head2 Format strings
493
494
The first parameter to new() is the format string which contains the following
495
special characters:
496
497
=over
498
499
=item characters '%d'
500
501
a revolving dash, format '/-\|'
502
503
=item characters '%t'
504
505
time elapsed, format 'hh:mm:ss'
506
507
=item characters '%b'
508
509
progress bar, format '#####_____'
510
511
=item characters '%p'
512
513
Progress in percentage, format '999%'
514
515
=item characters '%c'
516
517
Actual counter value (commified by '_'), format '99_999_999'
518
519
=item characters '%m'
520
521
Target maximum value (commified by '_'), format '99_999_999'
522
523
=item characters '%k'
524
525
Token which updates its value before being displayed. An example use
526
of this would be a loop wherein every step of the loop could be
527
identified by a particular string. For example:
528
529
my $ctr = Term::Sk->new('Processing %k counter %c',
530
{base => 0, token => 'Albania'});
531
foreach my $country (@list_of_european_nations) {
532
$ctr->token($country);
533
for (1..500) {
534
$ctr->up;
535
## do something...
536
}
537
};
538
$ctr->close;
539
540
You can also have more than one token on a single line. Here is an example:
541
542
my $ctr = Term::Sk->new('Processing %k Region %k counter %c',
543
{base => 0, token => ['Albania', 'South']});
544
foreach my $country (@list_of_european_nations) {
545
$ctr->token([$country, 'North']);
546
for (1..500) {
547
$ctr->up;
548
## do something...
549
}
550
};
551
$ctr->close;
552
553
The C<token> method is used to update the token value immediately on the screen.
554
555
The C<tok_maybe> method is used to set the token value, but the screen is not refreshed immediately.
556
557
If '%k' is used, then the counter must be instantiated with an initial value for the token.
558
559
=item characters '%P'
560
561
The '%' character itself
562
563
=back
564
565
=head2 Options
566
567
The second parameter are the following options:
568
569
=over
570
571
=item option {freq => 999}
572
573
This option sets the refresh-frequency on STDOUT to every 999 up() or
574
down() calls. If {freq => 999} is not specified at all, then the
575
refresh-frequency is set by default to every up() or down() call.
576
577
=item option {freq => 's'}
578
579
This is a special case whereby the refresh-frequency on STDOUT is set to every
580
second.
581
582
=item option {freq => 'd'}
583
584
This is a special case whereby the refresh-frequency on STDOUT is set to every
585
1/10th of a second.
586
587
=item option {base => 0}
588
589
This specifies the base value from which to count. The default is 0
590
591
=item option {target => 10_000}
592
593
This specifies the maximum value to which to count. The default is 10_000.
594
595
=item option {pdisp => '!'}
596
597
This option (with the exclamation mark) is obsolete and has no effect whatsoever. The
598
progressbar will always be displayed using the hash-symbol "#".
599
600
=item option {quiet => 1}
601
602
This option disables most printing to STDOUT, but the content of the would be printed
603
line is still available using the method get_line(). The whisper-method, however,
604
still shows its output.
605
606
The default is in fact {quiet => !-t STDOUT}
607
608
=item option {num => '9_999'}
609
610
This option configures the output number format for the counters.
611
612
=item option {commify => sub{...}}
613
614
This option allows one to register a subroutine that formats the counters.
615
616
=item option {test => 1}
617
618
This option is used for testing purposes only, it disables all printing to STDOUT, even
619
the whisper shows no output. But again, the content of the would be printed line is
620
still available using the method get_line().
621
622
=back
623
624
=head2 Processing
625
626
The new() method immediately displays the initial values on screen. From now on,
627
nothing must be printed to STDOUT and/or STDERR. However, you can write to STDOUT during
628
the operation using the method whisper().
629
630
We can either count upwards, $ctr->up, or downwards, $ctr->down. Everytime we do so, the
631
value is either incremented or decremented and the new value is replaced on STDOUT. We should
632
do so regularly during the process. Both methods, $ctr->up(99) and $ctr->down(99) can take an
633
optional argument, in which case the value is incremented/decremented by the specified amount.
634
635
When our process has finished, we must close the counter ($ctr->close). By doing so, the last
636
displayed value is removed from STDOUT, as if nothing had happened. Now we are allowed to print
637
again to STDOUT and/or STDERR.
638
639
=head2 Post hoc transformation
640
641
In some cases it makes sense to redirected STDOUT to a flat file. In this case, the backspace
642
characters remain in the flat file.
643
644
There is a function "rem_backspace()" that removes the backspaces (including the characters that
645
they are supposed to remove) from a redirected file.
646
647
Here is a simplified example:
648
649
use Term::Sk qw(rem_backspace);
650
651
my $flatfile = "Test hijabc\010\010\010xyzklmttt\010\010yzz";
652
653
printf "before (len=%3d): '%s'\n", length($flatfile), $flatfile;
654
655
rem_backspace(\$flatfile);
656
657
printf "after (len=%3d): '%s'\n", length($flatfile), $flatfile;
658
659
=head1 AUTHOR
660
661
Klaus Eichner, January 2008
662
663
=head1 COPYRIGHT AND LICENSE
664
665
Copyright (C) 2008-2011 by Klaus Eichner
666
667
This library is free software; you can redistribute it and/or modify
668
it under the same terms as Perl itself.
669
670
=cut
Loggerhead is a web-based interface for Breezy
Version: 2.0.1