require 5; package Pod::Simple::Progress; $VERSION = '3.28'; 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 | 64.69 KB | 0644 |
|
Checker.pm | File | 5.24 KB | 0644 |
|
Debug.pm | File | 4.5 KB | 0644 |
|
DumpAsText.pm | File | 3.92 KB | 0644 |
|
DumpAsXML.pm | File | 4.29 KB | 0644 |
|
HTML.pm | File | 32.69 KB | 0644 |
|
HTMLBatch.pm | File | 39.55 KB | 0644 |
|
HTMLLegacy.pm | File | 2.69 KB | 0644 |
|
LinkSection.pm | File | 4.24 KB | 0644 |
|
Methody.pm | File | 3.48 KB | 0644 |
|
Progress.pm | File | 2.36 KB | 0644 |
|
PullParser.pm | File | 24.76 KB | 0644 |
|
PullParserEndToken.pm | File | 2.81 KB | 0644 |
|
PullParserStartToken.pm | File | 4.04 KB | 0644 |
|
PullParserTextToken.pm | File | 3.08 KB | 0644 |
|
PullParserToken.pm | File | 3.89 KB | 0644 |
|
RTF.pm | File | 21.14 KB | 0644 |
|
Search.pm | File | 32.7 KB | 0644 |
|
SimpleTree.pm | File | 4.47 KB | 0644 |
|
Subclassing.pod | File | 32.33 KB | 0644 |
|
Text.pm | File | 5.01 KB | 0644 |
|
TextContent.pm | File | 2.48 KB | 0644 |
|
TiedOutFH.pm | File | 2.67 KB | 0644 |
|
Transcode.pm | File | 699 B | 0644 |
|
TranscodeDumb.pm | File | 1.16 KB | 0644 |
|
TranscodeSmart.pm | File | 715 B | 0644 |
|
XHTML.pm | File | 24.93 KB | 0644 |
|
XMLOutStream.pm | File | 4.86 KB | 0644 |
|