require 5; package Pod::Simple::Progress; $VERSION = '3.35'; use strict; # Objects of this class are used for noting progress of an # operation every so often. Messages delivered more often than that # are suppressed. # # There's actually nothing in here that's specific to Pod processing; # but it's ad-hoc enough that I'm not willing to give it a name that # implies that it's generally useful, like "IO::Progress" or something. # # -- sburke # #-------------------------------------------------------------------------- sub new { my($class,$delay) = @_; my $self = bless {'quiet_until' => 1}, ref($class) || $class; $self->to(*STDOUT{IO}); $self->delay(defined($delay) ? $delay : 5); return $self; } sub copy { my $orig = shift; bless {%$orig, 'quiet_until' => 1}, ref($orig); } #-------------------------------------------------------------------------- sub reach { my($self, $point, $note) = @_; if( (my $now = time) >= $self->{'quiet_until'}) { my $goal; my $to = $self->{'to'}; print $to join('', ($self->{'quiet_until'} == 1) ? () : '... ', (defined $point) ? ( '#', ($goal = $self->{'goal'}) ? ( ' ' x (length($goal) - length($point)), $point, '/', $goal, ) : $point, $note ? ': ' : (), ) : (), $note || '', "\n" ); $self->{'quiet_until'} = $now + $self->{'delay'}; } return $self; } #-------------------------------------------------------------------------- sub done { my($self, $note) = @_; $self->{'quiet_until'} = 1; return $self->reach( undef, $note ); } #-------------------------------------------------------------------------- # Simple accessors: sub delay { return $_[0]{'delay'} if @_ == 1; $_[0]{'delay'} = $_[1]; return $_[0] } sub goal { return $_[0]{'goal' } if @_ == 1; $_[0]{'goal' } = $_[1]; return $_[0] } sub to { return $_[0]{'to' } if @_ == 1; $_[0]{'to' } = $_[1]; return $_[0] } #-------------------------------------------------------------------------- unless(caller) { # Simple self-test: my $p = __PACKAGE__->new->goal(5); $p->reach(1, "Primus!"); sleep 1; $p->reach(2, "Secundus!"); sleep 3; $p->reach(3, "Tertius!"); sleep 5; $p->reach(4); $p->reach(5, "Quintus!"); sleep 1; $p->done("All done"); } #-------------------------------------------------------------------------- 1; __END__
Name | Type | Size | Permission | Actions |
---|---|---|---|---|
BlackBox.pm | File | 70.9 KB | 0644 |
|
Checker.pm | File | 5.21 KB | 0644 |
|
Debug.pm | File | 4.52 KB | 0644 |
|
DumpAsText.pm | File | 3.94 KB | 0644 |
|
DumpAsXML.pm | File | 4.45 KB | 0644 |
|
HTML.pm | File | 33.8 KB | 0644 |
|
HTMLBatch.pm | File | 39.2 KB | 0644 |
|
HTMLLegacy.pm | File | 2.69 KB | 0644 |
|
LinkSection.pm | File | 4.24 KB | 0644 |
|
Methody.pm | File | 3.49 KB | 0644 |
|
Progress.pm | File | 2.36 KB | 0644 |
|
PullParser.pm | File | 25.13 KB | 0644 |
|
PullParserEndToken.pm | File | 2.82 KB | 0644 |
|
PullParserStartToken.pm | File | 4.05 KB | 0644 |
|
PullParserTextToken.pm | File | 3.28 KB | 0644 |
|
PullParserToken.pm | File | 3.91 KB | 0644 |
|
RTF.pm | File | 21.96 KB | 0644 |
|
Search.pm | File | 34.29 KB | 0644 |
|
SimpleTree.pm | File | 4.52 KB | 0644 |
|
Subclassing.pod | File | 32.51 KB | 0644 |
|
Text.pm | File | 4.98 KB | 0644 |
|
TextContent.pm | File | 2.46 KB | 0644 |
|
TiedOutFH.pm | File | 2.69 KB | 0644 |
|
Transcode.pm | File | 736 B | 0644 |
|
TranscodeDumb.pm | File | 2.63 KB | 0644 |
|
TranscodeSmart.pm | File | 715 B | 0644 |
|
XHTML.pm | File | 25.78 KB | 0644 |
|
XMLOutStream.pm | File | 4.56 KB | 0644 |
|