Term-Sk-0.14000775000000000000 012146227673 13263 5ustar00unknownunknown000000000000Term-Sk-0.14/Build.PL000664000000000000 50711600101307 14653 0ustar00unknownunknown000000000000use strict; use warnings; use 5.008; use Module::Build; Module::Build->new( module_name => 'Term::Sk', license => 'perl', configure_requires => { 'Module::Build' => 0.30 }, dist_abstract => 'Perl extension for displaying a progress indicator on a terminal', )->create_build_script; Term-Sk-0.14/Changes000664000000000000 732012146226531 14707 0ustar00unknownunknown000000000000Revision history for Term-Sk 0.01 20 Jun 2009 First version, released on an unsuspecting world. 0.02 24 Nov 2009 make option {quiet => !-t STDOUT} the default make option {pdisp => '!'} meaningless, i.e. always use "#" to display the progress bar 0.03 22 Jan 2010 add code to detect $ENV{TERM_SK_OUTPUT} to connect to, in which case {quiet =>...} is ignored add Build.PL add Sidenotes.pod make new() die on errors add "use IO::Handle" and replace "local $| = 1;" by "IO::Handle::flush();" 0.04 27 Mar 2010 add a function rem_backspace() that takes a file and removes backspaces from that file revert back to version 0.02 (except for "add Build.PL" and "make new() die on errors"), that is... - remove item from ver 0.03: "...add code to detect $ENV{TERM_SK_OUTPUT}..." - remove item from ver 0.03: "...add Sidenotes.pod..." - remove item from ver 0.03: "...add use IO::Handle and replace local $| = 1;..." 0.05 11 May 2010 in Build.PL and in Makefile.PL change requirement "use 5.10" to the less restrictive "use 5.8" 0.06 28 May 2010 add option {num => q{9'999}} to allow variable number formats add dynamic growth of a number, such that format: '%c of %m' outputs 2_870 of 9_274 Also, write something reasonable in file README 0.07 09 May 2011 Introduce a new format character "%k" (="Token"). Idea and patch provided by Bruce Ravel. Token which updates its value before being displayed. An example use of this would be a loop wherein every step of the loop could be identified by a particular string. 0.08 14 May 2011 In the POD documentation, remove the "or die..." from "my $ctr = Term::Sk->new(...) or die..." Also, as suggested by Salvatore Bonaccorso, change the POD documentation as follows: before: This option allows to register... after : This option allows one to register... Make subs log_info(), set_chunk_size() and set_bkup_size() effectively dummy operations (i.e. they don't have any effect whatsoever) 0.09 21 Jun 2011 refactor/simplify subroutine rem_backspace(). refactor/simplify time recording (subroutine show_maybe()) in subroutine token(): replace $self->up; by $self->show_maybe; add some more tests add initialiser 'mock_tm' and method mock_time() to mock time for testing add configure_requires => { 'Module::Build' => 0.30 } to Build.PL 0.10 16 Jul 2011 allow more than one token in a single line 0.11 19 Jul 2011 update the documentation and give some examples to allow more than one token in a single line 0.12 08 Dec 2012 make subroutine $sk->token() to display the progress immediately (replacing $self->show_maybe; by $self->show; inside the subroutine token) 0.13 30 Dec 2012 Bug #82102 for Term-Sk: [PATCH] Small Spelling error in manpage (Wed, 19 Dec 2012 07:21:10 +0100) https://rt.cpan.org/Public/Bug/Display.html?id=82102 >> Hi In Debian we are currently applying the attached patch to Term-Sk. We thought you might be interested >> in it, too. Thanks in advance, Salvatore Bonaccorso, Debian Perl Group >> -counter must be instantiated with an in tial value for the token. >> +counter must be instantiated with an initial value for the token. 0.14 19 May 2013 Add a new sub tok_maybe(), which is similar to token(), except that tok_maybe() calls $self->show_maybe; whereas... token() calls $self->show; Term-Sk-0.14/Makefile.PL000664000000000000 104311372234244 15362 0ustar00unknownunknown000000000000use 5.008; use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( NAME => 'Term::Sk', VERSION_FROM => 'lib/Term/Sk.pm', # finds $VERSION PREREQ_PM => {}, # e.g., Module::Name => 1.1 ($] >= 5.005 ? ## Add these new keywords supported since 5.005 (ABSTRACT_FROM => 'lib/Term/Sk.pm', # retrieve abstract from module AUTHOR => 'Klaus Eichner ') : ()), ); Term-Sk-0.14/MANIFEST000664000000000000 14611571171263 14526 0ustar00unknownunknown000000000000Changes MANIFEST Makefile.PL Build.PL README lib/Term/Sk.pm t/0010_test.t META.yml META.json Term-Sk-0.14/META.json000664000000000000 151112146227673 15041 0ustar00unknownunknown000000000000{ "abstract" : "Perl extension for displaying a progress indicator on a terminal", "author" : [ "unknown" ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4003, CPAN::Meta::Converter version 2.120921", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Term-Sk", "prereqs" : { "configure" : { "requires" : { "Module::Build" : "0.3" } } }, "provides" : { "Term::Sk" : { "file" : "lib/Term/Sk.pm", "version" : "0.14" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "0.14" } Term-Sk-0.14/META.yml000664000000000000 102512146227673 14671 0ustar00unknownunknown000000000000--- abstract: 'Perl extension for displaying a progress indicator on a terminal' author: - unknown build_requires: {} configure_requires: Module::Build: 0.3 dynamic_config: 1 generated_by: 'Module::Build version 0.4003, CPAN::Meta::Converter version 2.120921' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Term-Sk provides: Term::Sk: file: lib/Term/Sk.pm version: 0.14 resources: license: http://dev.perl.org/licenses/ version: 0.14 Term-Sk-0.14/README000664000000000000 425212146226561 14300 0ustar00unknownunknown000000000000Term-Sk Version 0.14 This is a Perl extension for displaying a progress indicator on a terminal. SYNOPSIS use Term::Sk; my $ctr = Term::Sk->new('%d Elapsed: %8t %21b %4p %2d (%8c of %11m)', {quiet => 0, freq => 10, base => 0, target => 100, pdisp => '!'}) or die "Error 0010: Term::Sk->new, ". "(code $Term::Sk::errcode) ". "$Term::Sk::errmsg"; $ctr->up for (1..100); $ctr->down for (1..100); $ctr->whisper('abc'); my last_line = $ctr->get_line; $ctr->close; print "Number of ticks: ", $ctr->ticks, "\n"; EXAMPLES 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 long running processes. A sample code fragment that uses Term::Sk: use Term::Sk; print qq{This is a test of "Term::Sk"\n\n}; my $target = 2_845; my $format = '%2d Elapsed: %8t %21b %4p %2d (%8c of %11m)'; my $ctr = Term::Sk->new($format, {freq => 10, base => 0, target => $target, pdisp => '!'}) or die "Error 0010: Term::Sk->new, ". "(code $Term::Sk::errcode) ". "$Term::Sk::errmsg"; for (1..$target) { $ctr->up; do_something(); } $ctr->close; sub do_something { my $test = 0; for my $i (0..10_000) { $test += sin($i) * cos($i); } } INSTALLATION To install this module, run the following commands: perl Build.PL perl Build perl Build test perl Build install SUPPORT AND DOCUMENTATION After installing, you can find documentation for this module with the perldoc command. perldoc Term::Sk You can also look for information at: RT, CPAN's request tracker http://rt.cpan.org/NoAuth/Bugs.html?Dist=Term-Sk AnnoCPAN, Annotated CPAN documentation http://annocpan.org/dist/Term-Sk CPAN Ratings http://cpanratings.perl.org/d/Term-Sk Search CPAN http://search.cpan.org/dist/Term-Sk/ COPYRIGHT AND LICENCE Copyright (C) 2008 Klaus Eichner This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Term-Sk-0.14/lib000775000000000000 012146227673 14031 5ustar00unknownunknown000000000000Term-Sk-0.14/lib/Term000775000000000000 012146227673 14740 5ustar00unknownunknown000000000000Term-Sk-0.14/lib/Term/Sk.pm000664000000000000 4667212146227622 16043 0ustar00unknownunknown000000000000package Term::Sk; use strict; use warnings; use Time::HiRes qw( time ); use Fcntl qw(:seek); require Exporter; our @ISA = qw(Exporter); our %EXPORT_TAGS = ( 'all' => [ qw(set_chunk_size set_bkup_size rem_backspace) ] ); our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); our @EXPORT = qw(); our $VERSION = '0.14'; our $errcode = 0; our $errmsg = ''; sub new { shift; my $self = {}; bless $self; $errcode = 0; $errmsg = ''; my %hash = (freq => 1, base => 0, target => 1_000, quiet => 0, test => 0, num => q{9_999}); %hash = (%hash, %{$_[1]}) if defined $_[1]; my $format = defined $_[0] ? $_[0] : '%8c'; $self->{base} = $hash{base}; $self->{target} = $hash{target}; $self->{quiet} = $hash{quiet}; $self->{test} = $hash{test}; $self->{format} = $format; $self->{freq} = $hash{freq}; $self->{value} = $hash{base}; $self->{mock_tm} = $hash{mock_tm}; $self->{oldtext} = ''; $self->{line} = ''; $self->{pdisp} = '#'; $self->{commify} = $hash{commify}; $self->{token} = defined($hash{token}) ? ref($hash{token}) eq 'ARRAY' ? $hash{token} : [$hash{token}] : []; unless (defined $self->{quiet}) { $self->{quiet} = !-t STDOUT; } if ($hash{num} eq '9') { $self->{sep} = ''; $self->{group} = 0; } else { my ($sep, $group) = $hash{num} =~ m{\A 9 ([^\d\+\-]) (9+) \z}xms or do { $errcode = 95; $errmsg = qq{Can't parse num => '$hash{num}'}; die sprintf('Error-%04d: %s', $errcode, $errmsg); }; $self->{sep} = $sep; $self->{group} = length($group); } # Here we de-compose the format into $self->{action} $self->{action} = []; my $fmt = $format; while ($fmt ne '') { if ($fmt =~ m{^ ([^%]*) % (.*) $}xms) { my ($literal, $portion) = ($1, $2); unless ($portion =~ m{^ (\d*) ([a-zA-Z]) (.*) $}xms) { $errcode = 100; $errmsg = qq{Can't parse '%[]' from '%$portion', total line is '$format'}; die sprintf('Error-%04d: %s', $errcode, $errmsg); } my ($repeat, $disp_code, $remainder) = ($1, $2, $3); if ($repeat eq '') { $repeat = 1; } if ($repeat < 1) { $repeat = 1; } unless ($disp_code eq 'b' or $disp_code eq 'c' or $disp_code eq 'd' or $disp_code eq 'm' or $disp_code eq 'p' or $disp_code eq 'P' or $disp_code eq 't' or $disp_code eq 'k') { $errcode = 110; $errmsg = qq{Found invalid display-code ('$disp_code'), expected ('b', 'c', 'd', 'm', 'p', 'P' 't' or 'k') in '%$portion', total line is '$format'}; die sprintf('Error-%04d: %s', $errcode, $errmsg); } push @{$self->{action}}, {type => '*lit', len => length($literal), lit => $literal} if length($literal) > 0; push @{$self->{action}}, {type => $disp_code, len => $repeat}; $fmt = $remainder; } else { push @{$self->{action}}, {type => '*lit', len => length($fmt), lit => $fmt}; $fmt = ''; } } # End of format de-composition $self->{tick} = 0; $self->{out} = 0; $self->{sec_begin} = $self->{mock_tm} ? $self->{mock_tm} : time; $self->{sec_print} = 0; $self->show; return $self; } sub mock_time { my $self = shift; $self->{mock_tm} = $_[0]; } sub whisper { my $self = shift; my $back = qq{\010} x length $self->{oldtext}; my $blank = q{ } x length $self->{oldtext}; $self->{line} = join('', $back, $blank, $back, @_, $self->{oldtext}); unless ($self->{test}) { local $| = 1; if ($self->{quiet}) { print @_; } else { print $self->{line}; } } } sub get_line { my $self = shift; return $self->{line}; } sub up { my $self = shift; $self->{value} += defined $_[0] ? $_[0] : 1; $self->show_maybe; } sub down { my $self = shift; $self->{value} -= defined $_[0] ? $_[0] : 1; $self->show_maybe; } sub close { my $self = shift; $self->{value} = undef; $self->show; } sub ticks { my $self = shift; return $self->{tick} } sub token { my $self = shift; my $tk = shift; $self->{token} = ref($tk) eq 'ARRAY' ? $tk : [$tk]; $self->show; } sub tok_maybe { my $self = shift; my $tk = shift; $self->{token} = ref($tk) eq 'ARRAY' ? $tk : [$tk]; $self->show_maybe; } sub DESTROY { my $self = shift; $self->close; } sub show_maybe { my $self = shift; $self->{line} = ''; my $sec_now = ($self->{mock_tm} ? $self->{mock_tm} : time) - $self->{sec_begin}; my $sec_prev = $self->{sec_print}; $self->{sec_print} = $sec_now; $self->{tick}++; if ($self->{freq} eq 's') { if (int($sec_prev) != int($sec_now)) { $self->show; } } elsif ($self->{freq} eq 'd') { if (int($sec_prev * 10) != int($sec_now * 10)) { $self->show; } } else { unless ($self->{tick} % $self->{freq}) { $self->show; } } } sub show { my $self = shift; $self->{out}++; my $back = qq{\010} x length $self->{oldtext}; my $blank = q{ } x length $self->{oldtext}; my $text = ''; if (defined $self->{value}) { # Here we compose a string based on $self->{action} (which, of course, is the previously de-composed format) my $tok_ind = 0; for my $act (@{$self->{action}}) { my ($type, $lit, $len) = ($act->{type}, $act->{lit}, $act->{len}); if ($type eq '*lit') { # print (= append to $text) a simple literal $text .= $lit; next; } if ($type eq 't') { # print (= append to $text) time elapsed in format 'hh:mm:ss' my $unit = int($self->{sec_print}); my $hour = int($unit / 3600); my $min = int(($unit % 3600) / 60); my $sec = $unit % 60; my $stamp = sprintf '%02d:%02d:%02d', $hour, $min, $sec; $text .= sprintf "%${len}.${len}s", $stamp; next; } if ($type eq 'd') { # print (= append to $text) a revolving dash in format '/-\|' $text .= substr('/-\|', $self->{out} % 4, 1) x $len; next; } if ($type eq 'b') { # print (= append to $text) progress indicator format '#####_____' my $progress = $self->{target} == $self->{base} ? 0 : int ($len * ($self->{value} - $self->{base}) / ($self->{target} - $self->{base}) + 0.5); if ($progress < 0) { $progress = 0 } elsif ($progress > $len) { $progress = $len } $text .= $self->{pdisp} x $progress.'_' x ($len - $progress); next; } if ($type eq 'p') { # print (= append to $text) progress in percentage format '999%' my $percent = $self->{target} == $self->{base} ? 0 : 100 * ($self->{value} - $self->{base}) / ($self->{target} - $self->{base}); $text .= sprintf "%${len}.${len}s", sprintf("%.0f%%", $percent); next; } if ($type eq 'P') { # print (= append to $text) literally '%' characters $text .= '%' x $len; next; } if ($type eq 'c') { # print (= append to $text) actual counter value (commified) $text .= sprintf "%${len}s", commify($self->{commify}, $self->{value}, $self->{sep}, $self->{group}); next; } if ($type eq 'm') { # print (= append to $text) target (commified) $text .= sprintf "%${len}s", commify($self->{commify}, $self->{target}, $self->{sep}, $self->{group}); next; } if ($type eq 'k') { # print (= append to $text) token $text .= sprintf "%-${len}s", $self->{token}[$tok_ind]; $tok_ind++; next; } # default: do nothing, in the (impossible) event that $type is none of '*lit', 't', 'b', 'p', 'P', 'c', 'm' or 'k' } # End of string composition } $self->{line} = join('', $back, $blank, $back, $text); unless ($self->{test} or $self->{quiet}) { local $| = 1; print $self->{line}; } $self->{oldtext} = $text; } sub commify { my $com = shift; if ($com) { return $com->($_[0]); } local $_ = shift; my ($sep, $group) = @_; if ($group > 0) { my $len = length($_); for my $i (1..$len) { last unless s/^([-+]?\d+)(\d{$group})/$1$sep$2/; } } return $_; } my $chunk_size = 10000; my $bkup_size = 80; # Decision by Klaus Eichner, 31-MAY-2011: # --------------------------------------- # Make subs log_info(), set_chunk_size() and set_bkup_size() effectively dummy operations (i.e. they # don't have any effect whatsoever) sub log_info { } sub set_chunk_size { } sub set_bkup_size { } sub rem_backspace { my ($fname) = @_; open my $ifh, '<', $fname or die "Error-0200: Can't open < '$fname' because $!"; open my $tfh, '+>', undef or die "Error-0210: Can't open +> undef (tempfile) because $!"; my $out_buf = ''; while (read($ifh, my $inp_buf, $chunk_size)) { $out_buf .= $inp_buf; # here we are removing the backspaces: while ($out_buf =~ m{\010+}xms) { my $pos_left = $-[0] * 2 - $+[0]; if ($pos_left < 0) { $pos_left = 0; } $out_buf = substr($out_buf, 0, $pos_left).substr($out_buf, $+[0]); } if (length($out_buf) > $bkup_size) { print {$tfh} substr($out_buf, 0, -$bkup_size); $out_buf = substr($out_buf, -$bkup_size); } } CORE::close $ifh; # We need to employ CORE::close because there is already another close subroutine defined in the current namespace "Term::Sk" print {$tfh} $out_buf; # Now copy back temp-file to original file: seek $tfh, 0, SEEK_SET or die "Error-0220: Can't seek tempfile to 0 because $!"; open my $ofh, '>', $fname or die "Error-0230: Can't open > '$fname' because $!"; while (read($tfh, my $buf, $chunk_size)) { print {$ofh} $buf; } CORE::close $ofh; CORE::close $tfh; } 1; __END__ =head1 NAME Term::Sk - Perl extension for displaying a progress indicator on a terminal. =head1 SYNOPSIS use Term::Sk; my $ctr = Term::Sk->new('%d Elapsed: %8t %21b %4p %2d (%8c of %11m)', {quiet => 0, freq => 10, base => 0, target => 100, pdisp => '!'}); $ctr->up for (1..100); $ctr->down for (1..100); $ctr->whisper('abc'); my last_line = $ctr->get_line; $ctr->close; print "Number of ticks: ", $ctr->ticks, "\n"; =head1 EXAMPLES 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 long running processes. A sample code fragment that uses Term::Sk: use Term::Sk; print qq{This is a test of "Term::Sk"\n\n}; my $target = 2_845; my $format = '%2d Elapsed: %8t %21b %4p %2d (%8c of %11m)'; my $ctr = Term::Sk->new($format, {freq => 10, base => 0, target => $target, pdisp => '!'}); for (1..$target) { $ctr->up; do_something(); } $ctr->close; sub do_something { my $test = 0; for my $i (0..10_000) { $test += sin($i) * cos($i); } } Another example that counts upwards: use Term::Sk; my $format = '%21b %4p'; my $ctr = Term::Sk->new($format, {freq => 's', base => 0, target => 70}); for (1..10) { $ctr->up(7); sleep 1; } $ctr->close; At any time, after Term::Sk->new(), you can query the number of ticks (i.e. number of calls to $ctr->up or $ctr->down) using the method 'ticks': use Term::Sk; my $ctr = Term::Sk->new('%6c', {freq => 's', base => 0, target => 70}); for (1..4288) { $ctr->up; } $ctr->close; print "Number of ticks: ", $ctr->ticks, "\n"; This example uses a simple progress bar in quiet mode (nothing is printed to STDOUT), but instead, the content of what would have been printed can now be extracted using the get_line() method: use Term::Sk; my $format = 'Ctr %4c'; my $ctr = Term::Sk->new($format, {freq => 2, base => 0, target => 10, quiet => 1}); my $line = $ctr->get_line; $line =~ s/\010/up; $line = $ctr->get_line; $line =~ s/\010/close; $line = $ctr->get_line; $line =~ s/\010/ ...} my $format = 'act %c max %m'; my $ctr1 = Term::Sk->new($format, {base => 1234567, target => 2345678}); # The following numbers are shown: act 1_234_567 max 2_345_678 my $ctr2 = Term::Sk->new($format, {base => 1234567, target => 2345678, num => q{9,999}}); # The following numbers are shown: act 1,234,567 max 2,345,678 my $ctr3 = Term::Sk->new($format, {base => 1234567, target => 2345678, num => q{9'99}}); # The following numbers are shown: act 1'23'45'67 max 2'34'56'78 my $ctr4 = Term::Sk->new($format, {base => 1234567, target => 2345678, num => q{9}}); # The following numbers are shown: act 1234567 max 2345678 my $ctr5 = Term::Sk->new($format, {base => 1234567, target => 2345678, commify => sub{ join '!', split m{}xms, $_[0]; }}); # The following numbers are shown: act 1!2!3!4!5!6!7 max 2!3!4!5!6!7!8 =head1 DESCRIPTION =head2 Format strings The first parameter to new() is the format string which contains the following special characters: =over =item characters '%d' a revolving dash, format '/-\|' =item characters '%t' time elapsed, format 'hh:mm:ss' =item characters '%b' progress bar, format '#####_____' =item characters '%p' Progress in percentage, format '999%' =item characters '%c' Actual counter value (commified by '_'), format '99_999_999' =item characters '%m' Target maximum value (commified by '_'), format '99_999_999' =item characters '%k' Token which updates its value before being displayed. An example use of this would be a loop wherein every step of the loop could be identified by a particular string. For example: my $ctr = Term::Sk->new('Processing %k counter %c', {base => 0, token => 'Albania'}); foreach my $country (@list_of_european_nations) { $ctr->token($country); for (1..500) { $ctr->up; ## do something... } }; $ctr->close; You can also have more than one token on a single line. Here is an example: my $ctr = Term::Sk->new('Processing %k Region %k counter %c', {base => 0, token => ['Albania', 'South']}); foreach my $country (@list_of_european_nations) { $ctr->token([$country, 'North']); for (1..500) { $ctr->up; ## do something... } }; $ctr->close; The C method is used to update the token value immediately on the screen. The C method is used to set the token value, but the screen is not refreshed immediately. If '%k' is used, then the counter must be instantiated with an initial value for the token. =item characters '%P' The '%' character itself =back =head2 Options The second parameter are the following options: =over =item option {freq => 999} This option sets the refresh-frequency on STDOUT to every 999 up() or down() calls. If {freq => 999} is not specified at all, then the refresh-frequency is set by default to every up() or down() call. =item option {freq => 's'} This is a special case whereby the refresh-frequency on STDOUT is set to every second. =item option {freq => 'd'} This is a special case whereby the refresh-frequency on STDOUT is set to every 1/10th of a second. =item option {base => 0} This specifies the base value from which to count. The default is 0 =item option {target => 10_000} This specifies the maximum value to which to count. The default is 10_000. =item option {pdisp => '!'} This option (with the exclamation mark) is obsolete and has no effect whatsoever. The progressbar will always be displayed using the hash-symbol "#". =item option {quiet => 1} This option disables most printing to STDOUT, but the content of the would be printed line is still available using the method get_line(). The whisper-method, however, still shows its output. The default is in fact {quiet => !-t STDOUT} =item option {num => '9_999'} This option configures the output number format for the counters. =item option {commify => sub{...}} This option allows one to register a subroutine that formats the counters. =item option {test => 1} This option is used for testing purposes only, it disables all printing to STDOUT, even the whisper shows no output. But again, the content of the would be printed line is still available using the method get_line(). =back =head2 Processing The new() method immediately displays the initial values on screen. From now on, nothing must be printed to STDOUT and/or STDERR. However, you can write to STDOUT during the operation using the method whisper(). We can either count upwards, $ctr->up, or downwards, $ctr->down. Everytime we do so, the value is either incremented or decremented and the new value is replaced on STDOUT. We should do so regularly during the process. Both methods, $ctr->up(99) and $ctr->down(99) can take an optional argument, in which case the value is incremented/decremented by the specified amount. When our process has finished, we must close the counter ($ctr->close). By doing so, the last displayed value is removed from STDOUT, as if nothing had happened. Now we are allowed to print again to STDOUT and/or STDERR. =head2 Post hoc transformation In some cases it makes sense to redirected STDOUT to a flat file. In this case, the backspace characters remain in the flat file. There is a function "rem_backspace()" that removes the backspaces (including the characters that they are supposed to remove) from a redirected file. Here is a simplified example: use Term::Sk qw(rem_backspace); my $flatfile = "Test hijabc\010\010\010xyzklmttt\010\010yzz"; printf "before (len=%3d): '%s'\n", length($flatfile), $flatfile; rem_backspace(\$flatfile); printf "after (len=%3d): '%s'\n", length($flatfile), $flatfile; =head1 AUTHOR Klaus Eichner, January 2008 =head1 COPYRIGHT AND LICENSE Copyright (C) 2008-2011 by Klaus Eichner This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Term-Sk-0.14/t000775000000000000 012146227673 13526 5ustar00unknownunknown000000000000Term-Sk-0.14/t/0010_test.t000664000000000000 2570612146226744 15521 0ustar00unknownunknown000000000000use strict; use warnings; use Test::More tests => 71; use_ok('Term::Sk'); { my $ctr = Term::Sk->new('%2d Elapsed: %8t %21b %4p %2d (%8c of %11m) %P', { test => 1 } ); ok(defined($ctr), 'Test-0010: standard counter works ok'); } { my $ctr = eval{ Term::Sk->new('%', { test => 1 } )}; ok($@, 'Test-0020: invalid id aborts ok'); like($@, qr{\AError-0*100}, 'Test-0030: with errorcode 100'); like($@, qr{Can't parse}, 'Test-0040: and error message Can\'t parse'); } { my $ctr = eval{ Term::Sk->new('%z', { test => 1 } )}; ok($@, 'Test-0050: unknown id aborts ok'); like($@, qr{\AError-0*110}, 'Test-0060: with errorcode 110'); like($@, qr{invalid display-code}, 'Test-0070: and error message invalid display-code'); } { my $ctr = Term::Sk->new('Test %d', { test => 1 } ); ok(defined($ctr), 'Test-0080: %d works ok'); is(content($ctr->get_line), 'Test -', 'Test-0090: first displays -'); $ctr->up; is(content($ctr->get_line), 'Test \\', 'Test-0100: then displays \\'); $ctr->up; is(content($ctr->get_line), 'Test |', 'Test-0110: then displays |'); $ctr->up; is(content($ctr->get_line), 'Test /', 'Test-0120: then displays /'); } { my $ctr = Term::Sk->new('Elapsed %8t', { test => 1 } ); ok(defined($ctr), 'Test-0125: %t works ok'); like(content($ctr->get_line), qr{^Elapsed \d{2}:\d{2}:\d{2}$}, 'Test-0130: and displays the time elapsed'); } { my $ctr = Term::Sk->new('Bar %10b', { test => 1, target => 20, pdisp => '!' } ); ok(defined($ctr), 'Test-0140: %b works ok'); $ctr->up for 1..11; is(content($ctr->get_line), 'Bar ######____', 'Test-0150: always use hash for progress bar'); } { my $ctr = Term::Sk->new('Percent %4p', { test => 1, target => 20 } ); ok(defined($ctr), 'Test-0160: %p works ok'); $ctr->up for 1..5; is(content($ctr->get_line), 'Percent 25%', 'Test-0170: and displays 25% after a quarter of it\'s way'); } { my $ctr = Term::Sk->new('%P', { test => 1 } ); ok(defined($ctr), 'Test-0180: %P (in captital letters) works ok'); is(content($ctr->get_line), '%', 'Test-0190: and displays a percent symbol'); } { my $ctr = Term::Sk->new('Ctr %5c', { test => 1, base => 1000 } ); ok(defined($ctr), 'Test-0200: %c works ok'); $ctr->up for 1..8; is(content($ctr->get_line), 'Ctr 1_008', 'Test-0210: and displays the correct counter value'); } { my $ctr = Term::Sk->new('Tgt %5m', { test => 1, target => 9876 } ); ok(defined($ctr), 'Test-0220: %m works ok'); is(content($ctr->get_line), 'Tgt 9_876', 'Test-0230: and displays the correct target value'); } { my $ctr = Term::Sk->new('Test', { test => 1 } ); ok(defined($ctr), 'Test-0240: Simple fixed text works ok'); $ctr->whisper('abc'); is(content($ctr->get_line), 'abcTest', 'Test-0250: and whisper() works as expected'); } { my $ctr = Term::Sk->new('Dummy', { test => 1 } ); ok(defined($ctr), 'Test-0260: Simple fixed text works ok'); $ctr->close; is(content($ctr->get_line), '', 'Test-0270: and close() works as expected'); } { my $ctr = Term::Sk->new('Dummy', { test => 1 } ); ok(defined($ctr), 'Test-0280: %c works ok'); $ctr->up for 1..27; is($ctr->ticks, 27, 'Test-0290: number of ticks are correct'); } { my $ctr = Term::Sk->new('num %2c of %2m', { test => 1, base => 3, target => 45678 } ); ok(defined($ctr), 'Test-0300: %2c of %2m works ok'); is(content($ctr->get_line), 'num 3 of 45_678', 'Test-0310: first number %2c of %2m displayed correctly'); $ctr->up(10); is(content($ctr->get_line), 'num 13 of 45_678', 'Test-0320: second number %2c of %2m displayed correctly'); $ctr->up(85612); is(content($ctr->get_line), 'num 85_625 of 45_678', 'Test-0330: third number %2c of %2m displayed correctly'); } { my $ctr = Term::Sk->new('num %c of %m', { test => 1, base => 1234567, target => 2345678, num => q{9,999} } ); ok(defined($ctr), 'Test-0340: %c of %m works ok'); is(content($ctr->get_line), 'num 1,234,567 of 2,345,678', 'Test-0350: first number %c of %m displayed correctly'); } { my $ctr = Term::Sk->new('num %c of %m', { test => 1, base => 1234567, target => 2345678, num => q{9 999} } ); ok(defined($ctr), 'Test-0360: %c of %m works ok'); is(content($ctr->get_line), 'num 1 234 567 of 2 345 678', 'Test-0370: first number %c of %m displayed correctly'); } { my $ctr = Term::Sk->new('num %c of %m', { test => 1, base => 1234567, target => 2345678, num => q{9_999} } ); ok(defined($ctr), 'Test-0380: %c of %m works ok'); is(content($ctr->get_line), 'num 1_234_567 of 2_345_678', 'Test-0390: first number %c of %m displayed correctly'); } { my $ctr = Term::Sk->new('num %c of %m', { test => 1, base => 1234567, target => 2345678, num => q{9_99} } ); ok(defined($ctr), 'Test-0400: %c of %m works ok'); is(content($ctr->get_line), 'num 1_23_45_67 of 2_34_56_78', 'Test-0410: first number %c of %m displayed correctly'); } { my $ctr = Term::Sk->new('num %c of %m', { test => 1, base => 1234567, target => 2345678, num => q{9} } ); ok(defined($ctr), 'Test-0420: %c of %m works ok'); is(content($ctr->get_line), 'num 1234567 of 2345678', 'Test-0430: first number %c of %m displayed correctly'); } { my $ctr = Term::Sk->new('num %c of %m', { test => 1, base => 1234567, target => 2345678, num => q{9'999} } ); ok(defined($ctr), 'Test-0440: %c of %m works ok'); is(content($ctr->get_line), q{num 1'234'567 of 2'345'678}, 'Test-0450: first number %c of %m displayed correctly'); } { my $ctr = eval{Term::Sk->new('num %c of %m', { test => 1, base => 1234567, target => 2345678, num => q{8'888} } )}; ok($@, 'Test-0460: fails ok'); like($@, qr{Can't [ ] parse [ ] num}xms, 'Test-0470: error message'); } { my $flatfile = "Test hijabc\010\010\010xyzklm"; Term::Sk::rem_backspace(\$flatfile); is($flatfile, 'Test hijxyzklm', 'Test-0480: backspaces have been removed'); } { my $flatfile = ('abcde' x 37).("\010" x 28).'fghij'; Term::Sk::rem_backspace(\$flatfile); is(length($flatfile), 162, 'Test-0540: length abcde (200,15)'); is(substr($flatfile, -10), 'cdeabfghij', 'Test-0560: trailing characters for abcde (200,15)'); } { my $ctr = Term::Sk->new('num %c of %m', { test => 1, base => 1234567, target => 2345678, commify => sub{ join '!', split m{}xms, $_[0]; } }); ok(defined($ctr), 'Test-0590: commify sub works ok'); is(content($ctr->get_line), 'num 1!2!3!4!5!6!7 of 2!3!4!5!6!7!8', 'Test-0600: show commified numbers'); } { my $ctr = Term::Sk->new('Token %6k Ctr %c', { test => 1, base => 1, token => 'Spain' } ); ok(defined($ctr), 'Test-0610: %6k %c works ok'); is(content($ctr->get_line), q{Token Spain Ctr 1}, 'Test-0620: first Token displayed correctly'); $ctr->token('USA'); is(content($ctr->get_line), q{Token USA Ctr 1}, 'Test-0630: second Token displayed correctly'); $ctr->tok_maybe('China'); is(content($ctr->get_line), q{Token China Ctr 1}, 'Test-0632: third Token displayed correctly'); } { # mock-time = Tue Jun 21 14:21:02-28 2011 my $ctr = Term::Sk->new('Time %8t Ctr %c', { test => 1, base => 3, mock_tm => 1308658862.287032} ); ok(defined($ctr), 'Test-0640: %8t %c works ok'); is(content($ctr->get_line), q{Time 00:00:00 Ctr 3}, 'Test-0650: first Time displayed correctly'); # mock-time = Tue Jun 21 14:29:37-53 2011 $ctr->mock_time(1308659377.534502); $ctr->up; is(content($ctr->get_line), q{Time 00:08:35 Ctr 4}, 'Test-0660: second Time displayed correctly'); } { # mock-time = Tue Jun 21 14:21:02-28 2011 my $ctr = Term::Sk->new('Time %8t %d Ctr %c', { test => 1, base => 2, mock_tm => 1308658862.287032} ); ok(defined($ctr), 'Test-0670: %8t %d %c works ok'); is(content($ctr->get_line), q{Time 00:00:00 - Ctr 2}, 'Test-0680: first Time displayed correctly'); # mock-time = Tue Jun 21 14:21:02-29 2011 $ctr->mock_time(1308658862.291483); $ctr->up; is(content($ctr->get_line), q{Time 00:00:00 \ Ctr 3}, 'Test-0690: second Time displayed, dash has not changed'); # mock-time = Tue Jun 21 14:21:02-32 2011 $ctr->mock_time(1308658862.323717); $ctr->up; is(content($ctr->get_line), q{Time 00:00:00 | Ctr 4}, 'Test-0700: third Time displayed, dash has changed'); # mock-time = Tue Jun 21 14:21:03-29 2011 $ctr->mock_time(1308658863.2911543); $ctr->up; is(content($ctr->get_line), q{Time 00:00:01 / Ctr 5}, 'Test-0710: fourth Time displayed, Time and dash have changed'); } { my $flatfile = "Test hijabc\010\010\010xyzklmttt\010\010yzz"; (my $disp_before = $flatfile) =~ s{\010}'<'xmsg; is($disp_before, q{Test hijabc<<new('Token1 %6k Token2 %6k Ctr %c', { test => 1, base => 1, token => ['abc', 'def'] } ); ok(defined($ctr), 'Test-0740: %6k %6k %c works ok'); is(content($ctr->get_line), q{Token1 abc Token2 def Ctr 1}, 'Test-0750: first double Token displayed correctly'); $ctr->token(['ghi', 'jkl']); is(content($ctr->get_line), q{Token1 ghi Token2 jkl Ctr 1}, 'Test-0760: second double Token displayed correctly'); } sub content { my ($text) = @_; $text =~ s{^ \010+ \s+ \010+}{}xmsg; return $text; }