File Coverage

blib/lib/Term/Sk.pm

Criterion	Covered	Total	%
statement	198	219	90.4
branch	74	102	72.5
condition	22	24	91.6
subroutine	19	23	82.6
pod	0	17	0.0
total	313	385	81.3

package 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.16';

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;

                $stamp = substr($stamp, -$len) if length($stamp) > $len;

                $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__