]> git.donarmstrong.com Git - term-progressbar.git/blob - lib/Term/ProgressBar.pm
01a4bd25171d0136bad4bc99fc0cddb36b062e01
[term-progressbar.git] / lib / Term / ProgressBar.pm
1 package Term::ProgressBar;
2
3 #XXX TODO Redo original test with count=20
4 #         Amount Output
5 #         Amount Prefix/Suffix
6 #         Tinker with $0?
7 #         Test use of last_update (with update(*undef*)) with scales
8 #         Choice of FH other than STDERR
9 #         If no term, output no progress bar; just progress so far
10 #         Use of simple term with v2.0 bar
11 #         If name is wider than term, trim name
12 #         Don't update progress bar on new?
13
14 =head1 NAME
15
16 Term::ProgressBar - provide a progress meter on a standard terminal
17
18 =head1 SYNOPSIS
19
20   use Term::ProgressBar;
21
22   $progress = Term::ProgressBar->new ({count => $count});
23   $progress->update ($so_far);
24
25 =head1 DESCRIPTION
26
27 Term::ProgressBar provides a simple progress bar on the terminal, to let the
28 user know that something is happening, roughly how much stuff has been done,
29 and maybe an estimate at how long remains.
30
31 A typical use sets up the progress bar with a number of items to do, and then
32 calls L<update|"update"> to update the bar whenever an item is processed.
33
34 Often, this would involve updating the progress bar many times with no
35 user-visible change.  To avoid uneccessary work, the update method returns a
36 value, being the update value at which the user will next see a change.  By
37 only calling update when the current value exceeds the next update value, the
38 call overhead is reduced.
39
40 Remember to call the C<< $progress->update($max_value) >> when the job is done
41 to get a nice 100% done bar.
42
43 A progress bar by default is simple; it just goes from left-to-right, filling
44 the bar with '=' characters.  These are called B<major> characters.  For
45 long-running jobs, this may be too slow, so two additional features are
46 available: a linear completion time estimator, and/or a B<minor> character:
47 this is a character that I<moves> from left-to-right on the progress bar (it
48 does not fill it as the major character does), traversing once for each
49 major-character added.  This exponentially increases the granularity of the
50 bar for the same width.
51
52 =head1 EXAMPLES
53
54 =head2 A really simple use
55
56   #!/usr/bin/perl
57
58   use Term::ProgressBar 2.00;
59
60   use constant MAX => 100_000;
61
62   my $progress = Term::ProgressBar->new(MAX);
63
64   for (0..MAX) {
65     my $is_power = 0;
66     for(my $i = 0; 2**$i <= $_; $i++) {
67       $is_power = 1
68         if 2**$i == $_;
69     }
70
71     if ( $is_power ) {
72       $progress->update($_);
73     }
74   }
75
76 see eg/simle_use.pl
77
78 Here is a simple example.  The process considers all the numbers between 0 and
79 MAX, and updates the progress bar whenever it finds one.  Note that the
80 progress bar update will be very erratic.  See below for a smoother example.
81 Note also that the progress bar will never complete; see below to solve this.
82
83 The complete text of this example is in F<examples/powers> in the
84 distribution set (it is not installed as part of the module).
85
86 =head2 A smoother bar update
87
88   my $progress = Term::ProgressBar->new($max);
89
90   for (0..$max) {
91     my $is_power = 0;
92     for(my $i = 0; 2**$i <= $_; $i++) {
93       $is_power = 1
94         if 2**$i == $_;
95     }
96
97     $progress->update($_)
98   }
99
100 See eg/smooth_bar.pl
101
102 This example calls update for each value considered.  This will result in a
103 much smoother progress update, but more program time is spent updating the bar
104 than doing the "real" work.  See below to remedy this.  This example does
105 I<not> call C<< $progress->update($max); >> at the end, since it is
106 unnecessary, and ProgressBar will throw an exception at an attempt to update a
107 finished bar.
108
109 The complete text of this example is in F<examples/powers2> in the
110 distribution set (it is not installed as part of the module.
111
112 =head2 A (much) more efficient update
113
114   my $progress = Term::ProgressBar->new({name => 'Powers', count => $max, remove => 1});
115   $progress->minor(0);
116   my $next_update = 0;
117
118   for (0..$max) {
119     my $is_power = 0;
120     for(my $i = 0; 2**$i <= $_; $i++) {
121       $is_power = 1
122         if 2**$i == $_;
123     }
124
125     $next_update = $progress->update($_)
126       if $_ >= $next_update;
127   }
128   $progress->update($max)
129     if $max >= $next_update;
130
131 This example does two things to improve efficiency: firstly, it uses the value
132 returned by L<update|"update"> to only call it again when needed; secondly, it
133 switches off the use of minor characters to update a lot less frequently (C<<
134 $progress->minor(0); >>.  The use of the return value of L<update|"update">
135 means that the call of C<< $progress->update($max); >> at the end is required
136 to ensure that the bar ends on 100%, which gives the user a nice feeling.
137
138 This example also sets the name of the progress bar.
139
140 This example also demonstrates the use of the 'remove' flag, which removes the
141 progress bar from the terminal when done.
142
143 The complete text of this example is in F<examples/powers3> in the
144 distribution set (it is not installed as part of the module.
145
146 =head2 Using Completion Time Estimation
147
148   my $progress = Term::ProgressBar->new({name  => 'Powers',
149                                          count => $max,
150                                          ETA   => 'linear', });
151   $progress->max_update_rate(1);
152   my $next_update = 0;
153
154   for (0..$max) {
155     my $is_power = 0;
156     for(my $i = 0; 2**$i <= $_; $i++) {
157       if ( 2**$i == $_ ) {
158         $is_power = 1;
159         $progress->message(sprintf "Found %8d to be 2 ** %2d", $_, $i);
160       }
161     }
162
163     $next_update = $progress->update($_)
164       if $_ > $next_update;
165   }
166   $progress->update($max)
167       if $max >= $next_update;
168
169 This example uses the L<ETA|"ETA"> option to switch on completion estimation.
170 Also, the update return is tuned to try to update the bar approximately once
171 per second, with the L<max_update_rate|"max_update_rate"> call.  See the
172 documentation for the L<new|new> method for details of the format(s) used.
173
174 This example also provides an example of the use of the L<message|"message">
175 function to output messages to the same filehandle whilst keeping the progress bar intact
176
177 The complete text of this example is in F<examples/powers5> in the
178 distribution set (it is not installed as part of the module.
179
180 =cut
181
182 # ----------------------------------------------------------------------
183
184 # Pragmas --------------------------
185
186 use strict;
187
188 # Inheritance ----------------------
189
190 use base qw( Exporter );
191 use vars '@EXPORT_OK';
192 @EXPORT_OK = qw( $PACKAGE $VERSION );
193
194 # Utility --------------------------
195
196 use Carp                    qw( croak );
197 use Class::MethodMaker 1.02 qw( );
198 use Fatal                   qw( open sysopen close seek );
199 use POSIX                   qw( ceil strftime );
200
201 # ----------------------------------------------------------------------
202
203 # CLASS METHODS --------------------------------------------------------
204
205 # ----------------------------------
206 # CLASS CONSTANTS
207 # ----------------------------------
208
209 =head1 CLASS CONSTANTS
210
211 Z<>
212
213 =cut
214
215 use constant MINUTE => 60;
216 use constant HOUR   => 60 * MINUTE;
217 use constant DAY    => 24 * HOUR;
218
219 # The point past which to give ETA of just date, rather than time
220 use constant ETA_DATE_CUTOFF => 3 * DAY;
221 # The point past which to give ETA of time, rather time left
222 use constant ETA_TIME_CUTOFF => 10 * MINUTE;
223 # The ratio prior to which to not dare any estimates
224 use constant PREDICT_RATIO => 0.01;
225
226 use constant DEFAULTS => {
227                           lbrack     => '[',
228                           rbrack     => ']',
229                           minor_char => '*',
230                           major_char => '=',
231                           fh         => \*STDERR,
232                           name       => undef,
233                           ETA        => undef,
234                           max_update_rate => 0.5,
235
236                           # The following defaults are never used, but the keys
237                           # are valuable for error checking
238                           count      => undef,
239                           bar_width  => undef,
240                           term_width => undef,
241                           term       => undef,
242                           remove     => 0,
243                          };
244
245 use constant ETA_TYPES => { map { $_ => 1 } qw( linear ) };
246
247 use constant ALREADY_FINISHED => 'progress bar already finished';
248
249 use constant DEBUG => 0;
250
251 # -------------------------------------
252
253 use vars qw($PACKAGE $VERSION);
254 $PACKAGE = 'Term-ProgressBar';
255 $VERSION = '2.14';
256
257 # ----------------------------------
258 # CLASS CONSTRUCTION
259 # ----------------------------------
260
261 # ----------------------------------
262 # CLASS COMPONENTS
263 # ----------------------------------
264
265 # This is here to allow testing to redirect away from the terminal but still
266 # see terminal output, IYSWIM
267 my $__FORCE_TERM = 0;
268
269 # ----------------------------------
270 # CLASS HIGHER-LEVEL FUNCTIONS
271 # ----------------------------------
272
273 # ----------------------------------
274 # CLASS HIGHER-LEVEL PROCEDURES
275 # ----------------------------------
276
277 sub __force_term {
278   my $class = shift;
279   ($__FORCE_TERM) = @_;
280 }
281
282 # ----------------------------------
283 # CLASS UTILITY FUNCTIONS
284 # ----------------------------------
285
286 sub term_size {
287   my ($fh) = @_;
288
289   eval {
290     require Term::ReadKey;
291   }; if ($@) {
292     warn "Guessing terminal width due to problem with Term::ReadKey\n";
293     return 50;
294   }
295
296   my $result;
297   eval {
298     $result = (Term::ReadKey::GetTerminalSize($fh))[0];
299     $result-- if ($^O eq "MSWin32");
300   }; if ( $@ ) {
301     warn "error from Term::ReadKey::GetTerminalSize(): $@";
302   }
303
304   # If GetTerminalSize() failed it should (according to its docs)
305   # return an empty list.  It doesn't - that's why we have the eval {}
306   # above - but also it may appear to succeed and return a width of
307   # zero.
308   #
309   if ( ! $result ) {
310     $result = 50;
311     warn "guessing terminal width $result\n";
312   }
313
314   return $result;
315 }
316
317
318 # INSTANCE METHODS -----------------------------------------------------
319
320 # ----------------------------------
321 # INSTANCE CONSTRUCTION
322 # ----------------------------------
323
324 =head1 INSTANCE CONSTRUCTION
325
326 Z<>
327
328 =cut
329
330 # Don't document hash keys until tested that the give the desired affect!
331
332 =head2 new
333
334 Create & return a new Term::ProgressBar instance.
335
336 =over 4
337
338 =item ARGUMENTS
339
340 If one argument is provided, and it is a hashref, then the hash is treated as
341 a set of key/value pairs, with the following keys; otherwise, it is treated as
342 a number, being equivalent to the C<count> key.
343
344 =over 4
345
346 =item count
347
348 The item count.  The progress is marked at 100% when update I<count> is
349 invoked, and proportionally until then.
350
351 =item name
352
353 A name to prefix the progress bar with.
354
355 =item fh
356
357 The filehandle to output to.  Defaults to stderr.  Do not try to use
358 *foo{THING} syntax if you want Term capabilities; it does not work.  Pass in a
359 globref instead.
360
361 =item ETA
362
363 A total time estimation to use.  If enabled, a time finished estimation is
364 printed on the RHS (once sufficient updates have been performed to make such
365 an estimation feasible).  Naturally, this is an I<estimate>; no guarantees are
366 made.  The format of the estimate
367
368 Note that the format is intended to be as compact as possible while giving
369 over the relevant information.  Depending upon the time remaining, the format
370 is selected to provide some resolution whilst remaining compact.  Since the
371 time remaining decreases, the format typically changes over time.
372
373 As the ETA approaches, the format will state minutes & seconds left.  This is
374 identifiable by the word C<'Left'> at the RHS of the line.  If the ETA is
375 further away, then an estimate time of completion (rather than time left) is
376 given, and is identifiable by C<'ETA'> at the LHS of the ETA box (on the right
377 of the progress bar).  A time or date may be presented; these are of the form
378 of a 24 hour clock, e.g. C<'13:33'>, a time plus days (e.g., C<' 7PM+3'> for
379 around in over 3 days time) or a day/date, e.g. C<' 1Jan'> or C<'27Feb'>.
380
381 If ETA is switched on, the return value of L<update|"update"> is also
382 affected: the idea here is that if the progress bar seems to be moving quicker
383 than the eye would normally care for (and thus a great deal of time is spent
384 doing progress updates rather than "real" work), the next value is increased
385 to slow it.  The maximum rate aimed for is tunable via the
386 L<max_update_rate|"max_update_rate"> component.
387
388 The available values for this are:
389
390 =over 4
391
392 =item undef
393
394 Do not do estimation.  The default.
395
396 =item linear
397
398 Perform linear estimation.  This is simply that the amount of time between the
399 creation of the progress bar and now is divided by the current amount done,
400 and completion estimated linearly.
401
402 =back
403
404 =back
405
406 =item EXAMPLES
407
408   my $progress = Term::ProgressBar->new(100); # count from 1 to 100
409   my $progress = Term::ProgressBar->new({ count => 100 }); # same
410
411   # Count to 200 thingies, outputting to stdout instead of stderr,
412   # prefix bar with 'thingy'
413   my $progress = Term::ProgressBar->new({ count => 200,
414                                           fh    => \*STDOUT,
415                                           name  => 'thingy' });
416
417 =back
418
419 =cut
420
421 Class::MethodMaker->import (new_with_init => 'new',
422                             new_hash_init => 'hash_init',);
423
424 sub init {
425   my $self = shift;
426
427   # V1 Compatibility
428   return $self->init({count      => $_[1], name => $_[0],
429                       term_width => 50,    bar_width => 50,
430                       major_char => '#',   minor_char => '',
431                       lbrack     => '',    rbrack     => '',
432                       term       => '0 but true', })
433     if @_ == 2;
434
435   my $target;
436
437   croak
438     sprintf("Term::ProgressBar::new We don't handle this many arguments: %d",
439             scalar @_)
440     if @_ != 1;
441
442   my %config;
443
444   if ( UNIVERSAL::isa ($_[0], 'HASH') ) {
445     ($target) = @{$_[0]}{qw(count)};
446     %config = %{$_[0]}; # Copy in, so later playing does not tinker externally
447   } else {
448     ($target) = @_;
449   }
450
451   if ( my @bad = grep ! exists DEFAULTS->{$_}, keys %config )  {
452     croak sprintf("Input parameters (%s) to %s not recognized\n",
453                   join(':', @bad), 'Term::ProgressBar::new');
454   }
455
456   croak "Target count required for Term::ProgressBar new\n"
457     unless defined $target;
458
459   $config{$_} = DEFAULTS->{$_}
460     for grep ! exists $config{$_}, keys %{DEFAULTS()};
461   delete $config{count};
462
463   $config{term} = -t $config{fh}
464     unless defined $config{term};
465
466   if ( $__FORCE_TERM ) {
467     $config{term} = 1;
468     $config{term_width} = $__FORCE_TERM;
469     die "term width $config{term_width} (from __force_term) too small"
470       if $config{term_width} < 5;
471   } elsif ( $config{term} and ! defined $config{term_width}) {
472     $config{term_width} = term_size($config{fh});
473     die if $config{term_width} < 5;
474   }
475
476   unless ( defined $config{bar_width} ) {
477     if ( defined $config{term_width} ) {
478       # 5 for the % marker
479       $config{bar_width}  = $config{term_width} - 5;
480       $config{bar_width} -= $_
481         for map(( defined $config{$_} ? length($config{$_}) : 0),
482                   qw( lbrack rbrack name ));
483       $config{bar_width} -= 2 # Extra for ': '
484         if defined $config{name};
485       $config{bar_width} -= 10
486         if defined $config{ETA};
487       if ( $config{bar_width} < 1 ) {
488         warn "terminal width $config{term_width} too small for bar; defaulting to 10\n";
489         $config{bar_width} = 10;
490       }
491 #    } elsif ( ! $config{term} ) {
492 #      $config{bar_width}  = 1;
493 #      $config{term_width} = defined $config{ETA} ? 12 : 5;
494     } else {
495       $config{bar_width}  = $target;
496       die "configured bar_width $config{bar_width} < 1"
497       if $config{bar_width} < 1;
498     }
499   }
500
501   $config{start} = time;
502
503   select(((select $config{fh}), $| = 1)[0]);
504
505   $self->ETA(delete $config{ETA});
506
507   $self->hash_init (%config,
508
509                     offset        => 0,
510                     scale         => 1,
511
512                     last_update   => 0,
513                     last_position => 0,
514                    );
515   $self->target($target);
516   $self->minor($config{term} && $target > $config{bar_width} ** 1.5);
517
518   $self->update(0); # Initialize the progress bar
519 }
520
521
522 # ----------------------------------
523 # INSTANCE FINALIZATION
524 # ----------------------------------
525
526 # ----------------------------------
527 # INSTANCE COMPONENTS
528 # ----------------------------------
529
530 =head1 INSTANCE COMPONENTS
531
532 =cut
533
534 =head2 Scalar Components.
535
536 See L<Class::MethodMaker/get_set> for usage.
537
538 =over 4
539
540 =item target
541
542 The final target.  Updates are measured in terms of this.  Changes will have
543 no effect until the next update, but the next update value should be relative
544 to the new target.  So
545
546   $p = Term::ProgressBar({count => 20});
547   # Halfway
548   $p->update(10);
549   # Double scale
550   $p->target(40)
551   $p->update(21);
552
553 will cause the progress bar to update to 52.5%
554
555 =item max_update_rate
556
557 This value is taken as being the maximum speed between updates to aim for.
558 B<It is only meaningful if ETA is switched on.> It defaults to 0.5, being the
559 number of seconds between updates.
560
561 =back
562
563 =head2 Boolean Components
564
565 See L<Class::MethodMaker/get_set> for usage.
566
567 =over 4
568
569 =item minor
570
571 Default: set.  If unset, no minor scale will be calculated or updated.
572
573 Minor characters are used on the progress bar to give the user the idea of
574 progress even when there are so many more tasks than the terminal is wide that
575 the granularity would be too great.  By default, Term::ProgressBar makes a
576 guess as to when minor characters would be valuable.  However, it may not
577 always guess right, so this method may be called to force it one way or the
578 other.  Of course, the efficiency saving is minimal unless the client is
579 utilizing the return value of L<update|"update">.
580
581 See F<examples/powers4> and F<examples/powers3> to see minor characters in
582 action, and not in action, respectively.
583
584 =back
585
586 =head2 Configuration
587
588 =over 4
589
590 =item lbrack
591
592 Left bracket ( defaults to [ )
593
594  $progress->lbrack('<');
595
596 =item rbrack
597
598 Right bracket ( defaults to ] )
599
600  $progress->rbrack('>');
601
602 =back
603
604 =cut
605
606 # Private Scalar Components
607 #  offset    ) Default: 0.       Added to any value supplied to update.
608 #  scale     ) Default: 1.       Any value supplied to update is multiplied by
609 #                                this.
610 #  major_char) Default: '='.     The character printed for the major scale.
611 #  minor_char) Default: '*'.     The character printed for the minor scale.
612 #  name      ) Default: undef.   The name to print to the side of the bar.
613 #  fh        ) Default: STDERR.  The filehandle to output progress to.
614
615 # Private Counter Components
616 #  last_update  ) Default: 0.    The so_far value last time update was invoked.
617 #  last_position) Default: 0.    The number of the last progress mark printed.
618
619 # Private Boolean Components
620 #  term      ) Default: detected (by C<Term::ReadKey>).
621 #              If unset, we assume that we are not connected to a terminal (or
622 #              at least, not a suitably intelligent one).  Then, we attempt
623 #              minimal functionality.
624
625 Class::MethodMaker->import
626   (
627    get_set       => [qw/ major_units major_char
628                          minor_units minor_char
629                          lbrack      rbrack
630                          name
631                          offset      scale
632                          fh          start
633                          max_update_rate
634                      /],
635    counter       => [qw/ last_position last_update /],
636    boolean       => [qw/ minor name_printed pb_ended remove /],
637    # let it be boolean to handle 0 but true
638    get_set       => [qw/ term /],
639   );
640
641 # We generate these by hand since we want to check the values.
642 sub bar_width {
643     my $self = shift;
644     return $self->{bar_width} if not @_;
645     croak 'wrong number of arguments' if @_ != 1;
646     croak 'bar_width < 1' if $_[0] < 1;
647     $self->{bar_width} = $_[0];
648 }
649 sub term_width {
650     my $self = shift;
651     return $self->{term_width} if not @_;
652     croak 'wrong number of arguments' if @_ != 1;
653     croak 'term_width must be at least 5' if $self->term and $_[0] < 5;
654     $self->{term_width} = $_[0];
655 }
656
657 sub target {
658   my $self = shift;
659
660   if ( @_ ) {
661     my ($target) = @_;
662
663     if ( $target ) {
664       $self->major_units($self->bar_width / $target);
665       $self->minor_units($self->bar_width ** 2 / $target);
666       $self->minor      ( defined $self->term_width   and
667                           $self->term_width < $target );
668     }
669     $self->{target}  = $target;
670   }
671
672   return $self->{target};
673 }
674
675 sub ETA {
676   my $self = shift;
677
678   if (@_) {
679     my ($type) = @_;
680     croak "Invalid ETA type: $type\n"
681       if defined $type and ! exists ETA_TYPES->{$type};
682     $self->{ETA} = $type;
683   }
684
685   return $self->{ETA};
686 }
687
688 # ----------------------------------
689 # INSTANCE HIGHER-LEVEL FUNCTIONS
690 # ----------------------------------
691
692 # ----------------------------------
693 # INSTANCE HIGHER-LEVEL PROCEDURES
694 # ----------------------------------
695
696 =head1 INSTANCE HIGHER-LEVEL PROCEDURES
697
698 Z<>
699
700 =cut
701
702 sub no_minor {
703   warn sprintf("%s: This method is deprecated.  Please use %s instead\n",
704                (caller (0))[3], '$x->minor (0)',);
705   $_[0]->clear_minor (0);
706 }
707
708 # -------------------------------------
709
710 =head2 update
711
712 Update the progress bar.
713
714 =over 4
715
716 =item ARGUMENTS
717
718 =over 4
719
720 =item so_far
721
722 Current progress point, in whatever units were passed to C<new>.
723
724 If not defined, assumed to be 1+ whatever was the value last time C<update>
725 was called (starting at 0).
726
727 =back
728
729 =item RETURNS
730
731 =over 4
732
733 =item next_call
734
735 The next value of so_far at which to call C<update>.
736
737 =back
738
739 =back
740
741 =cut
742
743 sub update {
744   my $self = shift;
745   my ($so_far) = @_;
746
747   if ( ! defined $so_far ) {
748     $so_far = $self->last_update + 1;
749   }
750
751   my $input_so_far = $so_far;
752   $so_far *= $self->scale
753     unless $self->scale == 1;
754   $so_far += $self->offset;
755
756   my $target = my $next = $self->target;
757   my $name = $self->name;
758   my $fh = $self->fh;
759
760   if ( $target < 1 ) {
761     print $fh "\r";
762     printf $fh "$name: "
763       if defined $name;
764     print $fh "(nothing to do)\n";
765     return 2**32-1;
766   }
767
768   my $biggies     = $self->major_units * $so_far;
769   my @chars = (' ') x $self->bar_width;
770   $chars[$_] = $self->major_char
771     for 0..$biggies-1;
772
773   if ( $self->minor ) {
774     my $smally      = $self->minor_units * $so_far % $self->bar_width;
775     $chars[$smally] = $self->minor_char
776       unless $so_far == $target;
777     $next *= ($self->minor_units * $so_far + 1) / ($self->bar_width ** 2);
778   } else {
779     $next *= ($self->major_units * $so_far + 1) / $self->bar_width;
780   }
781
782   local $\ = undef;
783
784   if ( $self->term > 0 ) {
785     local $\ = undef;
786     my $to_print = "\r";
787     $to_print .= "$name: "
788       if defined $name;
789     my $ratio = $so_far / $target;
790     # Rounds down %
791     $to_print .= (sprintf ("%3d%% %s%s%s",
792                         $ratio * 100,
793                         $self->lbrack, join ('', @chars), $self->rbrack));
794     my $ETA = $self->ETA;
795     if ( defined $ETA and $ratio > 0 ) {
796       if ( $ETA eq 'linear' ) {
797         if ( $ratio == 1 ) {
798           my $taken = time - $self->start;
799           my $ss    = $taken % 60;
800           my $mm    = int(($taken % 3600) / 60);
801           my $hh    = int($taken / 3600);
802           if ( $hh > 99 ) {
803             $to_print .= sprintf('D %2dh%02dm', $hh, $mm, $ss);
804           } else {
805             $to_print .= sprintf('D%2dh%02dm%02ds', $hh, $mm, $ss);
806           }
807         } elsif ( $ratio < PREDICT_RATIO ) {
808           # No safe prediction yet
809           $to_print .= 'ETA ------';
810         } else {
811           my $time = time;
812           my $left = (($time - $self->start) * ((1 - $ratio) / $ratio));
813           if ( $left  < ETA_TIME_CUTOFF ) {
814             $to_print .= sprintf '%1dm%02ds Left', int($left / 60), $left % 60;
815           } else {
816             my $eta  = $time + $left;
817             my $format;
818             if ( $left < DAY ) {
819               $format = 'ETA  %H:%M';
820             } elsif ( $left < ETA_DATE_CUTOFF ) {
821               $format = sprintf('ETA %%l%%p+%d',$left/DAY);
822             } else {
823               $format = 'ETA %e%b';
824             }
825             $to_print .= strftime($format, localtime $eta);
826           }
827           # Calculate next to be at least SEC_PER_UPDATE seconds away
828           if ( $left > 0 ) {
829             my $incr = ($target - $so_far) / ($left / $self->max_update_rate);
830             $next = $so_far + $incr
831               if $so_far + $incr > $next;
832           }
833         }
834       } else {
835         croak "Bad ETA type: $ETA\n";
836       }
837     }
838     for ($self->{last_printed}) {
839         unless (defined and $_ eq $to_print) {
840             print $fh $to_print;
841         }
842         $_ = $to_print;
843     }
844
845     $next -= $self->offset;
846     $next /= $self->scale
847       unless $self->scale == 1;
848
849     if ( $so_far >= $target and $self->remove and ! $self->pb_ended) {
850       print $fh "\r", ' ' x $self->term_width, "\r";
851       $self->pb_ended;
852     }
853
854   } else {
855     local $\ = undef;
856
857     if ( $self->term ) { # special case for backwards compat.
858      if ( $so_far == 0 and defined $name and ! $self->name_printed ) {
859        print $fh "$name: ";
860        $self->set_name_printed;
861      }
862
863       my $position = int($self->bar_width * ($input_so_far / $target));
864       my $add      = $position - $self->last_position;
865       $self->last_position_incr ($add)
866         if $add;
867
868      print $fh $self->major_char x $add;
869
870      $next -= $self->offset;
871      $next /= $self->scale
872        unless $self->scale == 1;
873     } else {
874       my $pc = int(100*$input_so_far/$target);
875       printf $fh "[%s] %s: %3d%%\n", scalar(localtime), $name, $pc;
876
877       $next = ceil($target * ($pc+1)/100);
878     }
879
880     if ( $input_so_far >= $target ) {
881       if ( $self->pb_ended ) {
882         croak ALREADY_FINISHED;
883       } else {
884         if ( $self->term ) {
885           print $fh "\n"
886         }
887         $self->set_pb_ended;
888       }
889     }
890   }
891
892
893   $next = $target if $next > $target;
894
895   $self->last_update($input_so_far);
896   return $next;
897 }
898
899 # -------------------------------------
900
901 =head2 message
902
903 Output a message.  This is very much like print, but we try not to disturb the
904 terminal.
905
906 =over 4
907
908 =item ARGUMENTS
909
910 =over 4
911
912 =item string
913
914 The message to output.
915
916 =back
917
918 =back
919
920 =cut
921
922 sub message {
923   my $self = shift;
924   my ($string) = @_;
925   chomp ($string);
926
927   my $fh = $self->fh;
928   local $\ = undef;
929   if ( $self->term ) {
930     print $fh "\r", ' ' x $self->term_width;
931     print $fh "\r$string\n";
932   } else {
933     print $fh "\n$string\n";
934     print $fh $self->major_char x $self->last_position;
935   }
936   undef $self->{last_printed};
937   $self->update($self->last_update);
938 }
939
940
941 # ----------------------------------------------------------------------
942
943 =head1 REPORTING BUGS
944
945 via RT: L<https://rt.cpan.org/Dist/Display.html?Name=Pipe>
946
947 =head1 COMPATIBILITY
948
949 If exactly two arguments are provided, then L<new|"new"> operates in v1
950 compatibility mode: the arguments are considered to be name, and item count.
951 Various other defaults are set to emulate version one (e.g., the major output
952 character is '#', the bar width is set to 50 characters and the output
953 filehandle is not treated as a terminal). This mode is deprecated.
954
955 =head1 AUTHOR
956
957 Martyn J. Pearce fluffy@cpan.org
958
959 Significant contributions from Ed Avis, amongst others.
960
961 =head1 MAINTAINER
962
963 Gabor Szabo L<http://szabgab.com/>
964
965 =head1 COPYRIGHT
966
967 Copyright (c) 2001, 2002, 2003, 2004, 2005 Martyn J. Pearce.  This program is
968 free software; you can redistribute it and/or modify it under the same terms
969 as Perl itself.
970
971 =cut
972
973 1; # keep require happy.
974
975 __END__