Initial Commit

database/perl/lib/Pod/Simple/Progress.pm

@@ -0,0 +1,93 @@
+
+require 5;
+package Pod::Simple::Progress;
+$VERSION = '3.42';
+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__
+