File Coverage

blib/lib/Progress/Any.pm

Criterion	Covered	Total	%
statement	97	284	34.1
branch	47	174	27.0
condition	8	53	15.0
subroutine	15	26	57.6
pod	13	13	100.0
total	180	550	32.7

package Progress::Any;

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2020-07-10'; # DATE
our $DIST = 'Progress-Any'; # DIST
our $VERSION = '0.218'; # VERSION

use 5.010001;
use strict;
use warnings;

use Time::Duration qw();
use Time::HiRes qw(time);

sub import {
    my ($self, @args) = @_;
    my $caller = caller();
    for (@args) {
        if ($_ eq '$progress') {
            my $progress = $self->get_indicator(task => '');
            {
                no strict 'refs';
                my $v = "$caller\::progress";
                *$v = \$progress;
            }
        } else {
            die "Unknown import argument: $_";
        }
    }
}

# store Progress::Any objects for each task
our %indicators;  # key = task name

# store output objects
our %outputs;     # key = task name, value = [$outputobj, ...]

# internal attributes:
# - _elapsed (float*) = accumulated elapsed time so far
# - _start_time (float) = when is the last time the indicator state is changed
#     from 'stopped' to 'started'. when indicator is changed from 'started' to
#     'stopped', this will be set to undef.
# - _remaining = used to store user's estimation of remaining time. will be
#     unset after each update().

# return 1 if created, 0 if already created/initialized
sub _init_indicator {
    my ($class, $task, $default_target) = @_;

    #say "D: _init_indicator($task)";

    # prevent double initialization
    return $indicators{$task} if $indicators{$task};

    my $progress = bless({
        task        => $task,
        title       => $task,
        target      => $default_target,
        pos         => 0,
        state       => 'stopped',

        _remaining          => undef,
        _set_remaining_time => undef,
        _elapsed            => 0,
        _start_time         => 0,
    }, $class);
    $indicators{$task} = $progress;

    # if we create an indicator named a.b.c, we must also create a.b, a, and ''.
    if ($task =~ s/\.?\w+\z//) {
        $class->_init_indicator($task, 0);
    }

    $progress;
}

sub get_indicator {
    my ($class, %args) = @_;

    my %oargs = %args;

    my $task   = delete($args{task});
    if (!defined($task)) {
        my @caller = caller(0);
        #say "D:caller=".join(",",map{$_//""} @caller);
        $task = $caller[0] eq '(eval)' ? 'main' : $caller[0];
        $task =~ s/::/./g;
        $task =~ s/[^.\w]+/_/g;
    }
    die "Invalid task syntax '$task', please only use dotted words"
        unless $task =~ /\A(?:\w+(\.\w+)*)?\z/;

    my %uargs;

    my $p = $class->_init_indicator($task);
    for my $an (qw/title target pos remaining state/) {
        if (exists $args{$an}) {
            $uargs{$an} = delete($args{$an});
        }
    }
    die "Unknown argument(s) to get_indicator(): ".join(", ", keys(%args))
        if keys(%args);
    $p->_update(%uargs) if keys %uargs;

    $p;
}

my %attrs = (
    title     => {is => 'rw'},
    target    => {is => 'rw'},
    pos       => {is => 'rw'},
    state     => {is => 'rw'},
);

# create attribute methods
for my $an (keys %attrs) {
    next if $attrs{$an}{manual};
    my $code;
    if ($attrs{$an}{is} eq 'rw') {
        $code = sub {
            my $self = shift;
            if (@_) {
                $self->_update($an => shift);
            }
            $self->{$an};
        };
    } else {
        $code = sub {
            my $self = shift;
            die "Can't set value, $an is an ro attribute" if @_;
            $self->{$an};
        };
    }
    no strict 'refs';
    *{$an} = $code;
}

sub elapsed {
    my $self = shift;

    if ($self->{state} eq 'started') {
        return $self->{_elapsed} + (time()-$self->{_start_time});
    } else {
        return $self->{_elapsed};
    }
}

sub total_pos {
    my $self = shift;

    my $t = $self->{task};

    my $res = $self->{pos};
    for (keys %indicators) {
        if ($t eq '') {
            next if $_ eq '';
        } else {
            next unless index($_, "$t.") == 0;
        }
        $res += $indicators{$_}{pos};
    }
    $res;
}

sub total_target {
    my $self = shift;

    my $t = $self->{task};

    my $res = $self->{target};
    return undef unless defined($res);

    for (keys %indicators) {
        if ($t eq '') {
            next if $_ eq '';
        } else {
            next unless index($_, "$t.") == 0;
        }
        return undef unless defined $indicators{$_}{target};
        $res += $indicators{$_}{target};
    }
    $res;
}

sub percent_complete {
    my $self = shift;

    my $total_pos    = $self->total_pos;
    my $total_target = $self->total_target;

    return undef unless defined($total_target);
    if ($total_target == 0) {
        if ($self->{state} eq 'finished') {
            return 100;
        } else {
            return 0;
        }
    } else {
        return $total_pos / $total_target * 100;
    }
}

sub remaining {
    my $self = shift;

    if (defined $self->{_remaining}) {
        if ($self->{state} eq 'started') {
            my $r = $self->{_remaining}-(time()-$self->{_set_remaining_time});
            return $r > 0 ? $r : 0;
        } else {
            return $self->{_remaining};
        }
    } else {
        if (defined $self->{target}) {
            if ($self->{pos} == 0) {
                return 0;
            } else {
                return ($self->{target} - $self->{pos})/$self->{pos} *
                    $self->elapsed;
            }
        } else {
            return undef;
        }
    }
}

sub total_remaining {
    my $self = shift;

    my $t = $self->{task};

    my $res = $self->remaining;
    return undef unless defined $res;

    for (keys %indicators) {
        if ($t eq '') {
            next if $_ eq '';
        } else {
            next unless index($_, "$t.") == 0;
        }
        my $res2 = $indicators{$_}->remaining;
        return undef unless defined $res2;
        $res += $res2;
    }
    $res;
}

# the routine to use to update rw attributes, does validation and checks to make
# sure things are consistent.
sub _update {
    my ($self, %args) = @_;

    # no need to check for unknown arg in %args, it's an internal method anyway

    my $now = time();

    my $task = $self->{task};
    #use Data::Dump; print "D: _update($task) "; dd \%args;

  SET_TITLE:
    {
        last unless exists $args{title};
        my $val = $args{title};
        die "Invalid value for title, must be defined"
            unless defined($val);
        $self->{title} = $val;
    }

  SET_TARGET:
    {
        last unless exists $args{target};
        my $val = $args{target};
        die "Invalid value for target, must be a positive number or undef"
            unless !defined($val) || $val >= 0;
        # ensure that pos does not exceed target
        if (defined($val) && $self->{pos} > $val) {
            $self->{pos} = $val;
        }
        $self->{target} = $val;
        undef $self->{_remaining};
    }

  SET_POS:
    {
        last unless exists $args{pos};
        my $val = $args{pos};
        die "Invalid value for pos, must be a positive number"
            unless defined($val) && $val >= 0;
        # ensure that pos does not exceed target
        if (defined($self->{target}) && $val > $self->{target}) {
            $val = $self->{target};
        }
        $self->{pos} = $val;
        undef $self->{_remaining};
    }

  SET_REMAINING:
    {
        last unless exists $args{remaining};
        my $val = $args{remaining};
        die "Invalid value for remaining, must be a positive number"
            unless defined($val) && $val >= 0;
        $self->{_remaining} = $val;
        $self->{_set_remaining_time} = $now;
    }

  SET_STATE:
    {
        last unless exists $args{state};
        my $old = $self->{state};
        my $val = $args{state} // 'started';
        die "Invalid value for state, must be stopped/started/finished"
            unless $val =~ /\A(?:stopped|started|finished)\z/;
        last if $old eq $val;
        if ($val eq 'started') {
            $self->{_start_time} = $now;

            # automatically start parents
            my @parents;
            {
                my $t = $task;
                while (1) {
                    last unless $t =~ s/\.\w+\z//;
                    push @parents, $t;
                }
                push @parents, '';
            }
            for my $t (@parents) {
                my $p = $indicators{$t};
                if ($p->{state} ne 'started') {
                    $p->{state}       = 'started';
                    $p->{_start_time} = $now;
                }
            }
        } else {
            $self->{_elapsed} += $now - $self->{_start_time};
            if ($val eq 'finished') {
                die "BUG: Can't finish task '$task', pos is still < target"
                    if defined($self->{target}) &&
                        $self->{pos} < $self->{target};
                $self->{_remaining} = 0;
                $self->{_set_remaining_time} = $now;
            }
        }
        $self->{state} = $val;
    }

  DONE:
    #use Data::Dump; print "after update: "; dd $self;
    return;
}

sub _should_update_output {
    my ($self, $output, $now, $priority) = @_;

    my $key = "$output";
    if (!defined($output->{_mtime})) {
        # output has never been updated, update
        return 1;
    } elsif ($self->{state} eq 'finished') {
        # finishing, update the output to show finished state
        return 1;
    } elsif ($output->{force_update}) {
        # this is an undocumented force update for now, the output itself or
        # something else can set this to force an update. but this will only be
        # done once because we delete the key; if another update wants to be
        # forced, they need to set this again.
        delete $output->{force_update};
        return 1;
    } elsif ($priority eq 'high') {
        # high priority, send to output module
        return 1;
    } else {
        # normal-/low-priority update, update if not too frequent
        if (!defined($output->{freq})) {
            # negative number means seconds, positive means pos delta. only
            # update if that number of seconds, or that difference in pos has
            # been passed.
            $output->{freq} = -0.5;
        }
        if ($output->{freq} == 0) {
            return 1;
        } if ($output->{freq} < 0) {
            return 1 if $now >= $output->{_mtime} - $output->{freq};
        } else {
            return 1 if abs($self->{pos} - $output->{_pos}) >= $output->{freq};
        }
        return 0;
    }
}

sub update {
    my ($self, %args) = @_;

    my $pos   = delete($args{pos}) // $self->{pos} + 1;
    my $state = delete($args{state}) // 'started';
    $self->_update(pos => $pos, state => $state);

    my $message  = delete($args{message});
    my $priority = delete($args{priority}) // 'normal';
    my $force_update = delete($args{force_update});
    die "Unknown argument(s) to update(): ".join(", ", keys(%args))
        if keys(%args);

    my $now = time();

    # find output(s) and call it
    {
        last unless $ENV{PROGRESS} // 1;
        my $task = $self->{task};
        while (1) {
            if ($outputs{$task}) {
                for my $output (@{ $outputs{$task} }) {
                    next unless $force_update ||
                        $self->_should_update_output($output, $now, $priority);
                    if (ref($message) eq 'CODE') {
                        $message = $message->();
                    }
                    $output->update(
                        indicator => $indicators{$task},
                        message   => $message,
                        priority  => $priority,
                        time      => $now,

                        # temporary, internal API. to let an output module know
                        # the same update() when there are multiple instances of
                        # it
                        _update_id => $now,
                    );
                    $output->{_mtime} = $now;
                    $output->{_pos}   = $pos;
                }
            }
            last unless $task =~ s/\.?\w+\z//;
        }
    }
}

sub start {
    my $self = shift;
    $self->_update(state => 'started');
}

sub stop {
    my $self = shift;
    $self->_update(state => 'stopped');
}

sub finish {
    my ($self, %args) = @_;
    $self->update(pos=>$self->{target}, state=>'finished', %args);
}

sub reset {
    my ($self, %args) = @_;
    $self->update(pos=>0, state=>'started', %args);
}

our $template_regex = qr{( # all=1
                             %
                             ( #width=2
                                 -?\d+ )?
                             ( #dot=3
                                 \.?)
                             ( #prec=4
                                 \d+)?
                             ( #conv=5
                                 [A-Za-z%])
                         )}x;

sub fill_template {
    my ($self, $template0, %args) = @_;

    # TODO: some caching so "%e%e" produces two identical numbers

    my ($template, $opts);
    if (ref $template0 eq 'HASH') {
        $opts = $template0;
        $template = $opts->{template};
    } else {
        $template = $template0;
        $opts = {};
    }

    state $sub = sub {
        my %args = @_;

        my ($all, $width, $dot, $prec, $conv) = ($1, $2, $3, $4, $5);

        my $p = $args{indicator};

        my ($fmt, $sconv, $data);
        if ($conv eq 'n') {
            $data = $p->{task};
        } elsif ($conv eq 't') {
            $data = $p->{title};
        } elsif ($conv eq '%') {
            $data = '%';
        } elsif ($conv eq 'm') {
            $data = $args{message} // '';
        } elsif ($conv eq 'p') {
            my $val = $p->percent_complete;
            $width //= 3;
            if (defined $val) {
                $data = $val;
                $prec //= 0;
                $sconv = "f";
            } else {
                $data = '?';
            }
        } elsif ($conv eq 'P') {
            $data = $p->total_pos;
            $prec //= 0;
            $sconv = "f";
        } elsif ($conv eq 'T') {
            my $val = $p->total_target;
            if (defined $val) {
                $data = $val;
                $prec //= 0;
                $sconv = "f";
            } else {
                $data = '?';
            }
        } elsif ($conv eq 'e') {
            my $val = $p->elapsed;
            $val = 1 if $val < 1; # TMP, prevent duration() return "just now"
            $data = Time::Duration::concise(Time::Duration::duration($val));
            $width //= -8;
        } elsif ($conv eq 'r') {
            my $val = $p->total_remaining;
            if (defined $val) {
                $val = 1 if $val < 1; # TMP, prevent duration() return "just now
                $data = Time::Duration::concise(Time::Duration::duration($val));
            } else {
                $data = '?';
            }
            $width //= -8;
        } elsif ($conv eq 'R') {
            my $val = $p->total_remaining;
            if (defined $val) {
                $val = 1 if $val < 1; # TMP, prevent duration() return "just now
                $data = Time::Duration::concise(Time::Duration::duration($val)).
                    " left"; # XXX i18n
            } else {
                $val = $p->elapsed;
                $val = 1 if $val < 1; # TMP, prevent duration() return "just now
                $data = Time::Duration::concise(Time::Duration::duration($val)).
                    " elapsed"; # XXX i18n
            }
            $width //= -(8 + 1 + 7);
        } else {
            if ($opts->{handle_unknown_conversion}) {
                my @res = $opts->{handle_unknown_conversion}->(
                    indicator => $p,
                    args  => \%args,

                    all   => $all,
                    width => $width,
                    dot   => $dot,
                    conv  => $conv,
                    prec  => $prec,
                );
                if (@res) {
                    ($fmt, $data) = @res;
                } else {
                # return as-is
                    $fmt = '%s';
                    $data = $all;
                }
            } else {
                # return as-is
                $fmt = '%s';
                $data = $all;
            }
        }

        # sprintf format
        $sconv //= 's';
        $dot = "." if $sconv eq 'f';
        $fmt //= join("", grep {defined} ("%", $width, $dot, $prec, $sconv));

        #say "D:fmt=$fmt";
        sprintf $fmt, $data;
    };
    $template =~ s{$template_regex}{$sub->(%args, indicator=>$self)}egox;

    $template;
}

1;
# ABSTRACT: Record progress to any output

__END__