1
2require 5;
3package Pod::Simple::Progress;
4$VERSION = '3.28';
5use strict;
6
7# Objects of this class are used for noting progress of an
8#  operation every so often.  Messages delivered more often than that
9#  are suppressed.
10#
11# There's actually nothing in here that's specific to Pod processing;
12#  but it's ad-hoc enough that I'm not willing to give it a name that
13#  implies that it's generally useful, like "IO::Progress" or something.
14#
15# -- sburke
16#
17#--------------------------------------------------------------------------
18
19sub new {
20  my($class,$delay) = @_;
21  my $self = bless {'quiet_until' => 1},  ref($class) || $class;
22  $self->to(*STDOUT{IO});
23  $self->delay(defined($delay) ? $delay : 5);
24  return $self;
25}
26
27sub copy {
28  my $orig = shift;
29  bless {%$orig, 'quiet_until' => 1}, ref($orig);
30}
31#--------------------------------------------------------------------------
32
33sub reach {
34  my($self, $point, $note) = @_;
35  if( (my $now = time) >= $self->{'quiet_until'}) {
36    my $goal;
37    my    $to = $self->{'to'};
38    print $to join('',
39      ($self->{'quiet_until'} == 1) ? () : '... ',
40      (defined $point) ? (
41        '#',
42        ($goal = $self->{'goal'}) ? (
43          ' ' x (length($goal) - length($point)),
44          $point, '/', $goal,
45        ) : $point,
46        $note ? ': ' : (),
47      ) : (),
48      $note || '',
49      "\n"
50    );
51    $self->{'quiet_until'} = $now + $self->{'delay'};
52  }
53  return $self;
54}
55
56#--------------------------------------------------------------------------
57
58sub done {
59  my($self, $note) = @_;
60  $self->{'quiet_until'} = 1;
61  return $self->reach( undef, $note );
62}
63
64#--------------------------------------------------------------------------
65# Simple accessors:
66
67sub delay {
68  return $_[0]{'delay'} if @_ == 1; $_[0]{'delay'} = $_[1]; return $_[0] }
69sub goal {
70  return $_[0]{'goal' } if @_ == 1; $_[0]{'goal' } = $_[1]; return $_[0] }
71sub to   {
72  return $_[0]{'to'   } if @_ == 1; $_[0]{'to'   } = $_[1]; return $_[0] }
73
74#--------------------------------------------------------------------------
75
76unless(caller) { # Simple self-test:
77  my $p = __PACKAGE__->new->goal(5);
78  $p->reach(1, "Primus!");
79  sleep 1;
80  $p->reach(2, "Secundus!");
81  sleep 3;
82  $p->reach(3, "Tertius!");
83  sleep 5;
84  $p->reach(4);
85  $p->reach(5, "Quintus!");
86  sleep 1;
87  $p->done("All done");
88}
89
90#--------------------------------------------------------------------------
911;
92__END__
93
94