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 unnecessary 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                           silent     => 0,
 244                          };
 245
 246 use constant ETA_TYPES => { map { $_ => 1 } qw( linear ) };
 247
 248 use constant ALREADY_FINISHED => 'progress bar already finished';
 249
 250 use constant DEBUG => 0;
 251
 252 # -------------------------------------
 253
 254 use vars qw($PACKAGE $VERSION);
 255 $PACKAGE = 'Term-ProgressBar';
 256 $VERSION = '2.14';
 257
 258 # ----------------------------------
 259 # CLASS CONSTRUCTION
 260 # ----------------------------------
 261
 262 # ----------------------------------
 263 # CLASS COMPONENTS
 264 # ----------------------------------
 265
 266 # This is here to allow testing to redirect away from the terminal but still
 267 # see terminal output, IYSWIM
 268 my $__FORCE_TERM = 0;
 269
 270 # ----------------------------------
 271 # CLASS HIGHER-LEVEL FUNCTIONS
 272 # ----------------------------------
 273
 274 # ----------------------------------
 275 # CLASS HIGHER-LEVEL PROCEDURES
 276 # ----------------------------------
 277
 278 sub __force_term {
 279   my $class = shift;
 280   ($__FORCE_TERM) = @_;
 281 }
 282
 283 # ----------------------------------
 284 # CLASS UTILITY FUNCTIONS
 285 # ----------------------------------
 286
 287 sub term_size {
 288   my ( $self, $fh ) = @_;
 289   return if $self->silent;
 290
 291   eval {
 292     require Term::ReadKey;
 293   }; if ($@) {
 294     warn "Guessing terminal width due to problem with Term::ReadKey\n";
 295     return 50;
 296   }
 297
 298   my $result;
 299   eval {
 300     $result = (Term::ReadKey::GetTerminalSize($fh))[0];
 301     $result-- if ($^O eq "MSWin32");
 302   }; if ( $@ ) {
 303     warn "error from Term::ReadKey::GetTerminalSize(): $@";
 304   }
 305
 306   # If GetTerminalSize() failed it should (according to its docs)
 307   # return an empty list.  It doesn't - that's why we have the eval {}
 308   # above - but also it may appear to succeed and return a width of
 309   # zero.
 310   #
 311   if ( ! $result ) {
 312     $result = 50;
 313     warn "guessing terminal width $result\n";
 314   }
 315
 316   return $result;
 317 }
 318
 319
 320 # INSTANCE METHODS -----------------------------------------------------
 321
 322 # ----------------------------------
 323 # INSTANCE CONSTRUCTION
 324 # ----------------------------------
 325
 326 =head1 INSTANCE CONSTRUCTION
 327
 328 Z<>
 329
 330 =cut
 331
 332 # Don't document hash keys until tested that the give the desired affect!
 333
 334 =head2 new
 335
 336 Create & return a new Term::ProgressBar instance.
 337
 338 =over 4
 339
 340 =item ARGUMENTS
 341
 342 If one argument is provided, and it is a hashref, then the hash is treated as
 343 a set of key/value pairs, with the following keys; otherwise, it is treated as
 344 a number, being equivalent to the C<count> key.
 345
 346 =over 4
 347
 348 =item count
 349
 350 The item count.  The progress is marked at 100% when update I<count> is
 351 invoked, and proportionally until then.
 352
 353 =item name
 354
 355 A name to prefix the progress bar with.
 356
 357 =item fh
 358
 359 The filehandle to output to.  Defaults to stderr.  Do not try to use
 360 *foo{THING} syntax if you want Term capabilities; it does not work.  Pass in a
 361 globref instead.
 362
 363 =item term_width
 364
 365 Sometimes we can't correctly determine the terminal width. You can use this
 366 parameter to force a term width of a particular size. Use a positive integer,
 367 please :)
 368
 369 =item silent
 370
 371 If passed a true value, Term::ProgressBar will do nothing at all. Useful in
 372 scripts where the progress bar is optional (or just plain doesn't work due to
 373 issues with modules it relies on).
 374
 375 Instead, tell the constructor you want it to be silent and you don't need to
 376 change the rest of your program:
 377
 378     my $progress = Term::ProgressBar->new( { count => $count, silent => $silent } );
 379     # later
 380     $progress->update; # does nothing
 381
 382 =item ETA
 383
 384 A total time estimation to use.  If enabled, a time finished estimation is
 385 printed on the RHS (once sufficient updates have been performed to make such
 386 an estimation feasible).  Naturally, this is an I<estimate>; no guarantees are
 387 made.  The format of the estimate
 388
 389 Note that the format is intended to be as compact as possible while giving
 390 over the relevant information.  Depending upon the time remaining, the format
 391 is selected to provide some resolution whilst remaining compact.  Since the
 392 time remaining decreases, the format typically changes over time.
 393
 394 As the ETA approaches, the format will state minutes & seconds left.  This is
 395 identifiable by the word C<'Left'> at the RHS of the line.  If the ETA is
 396 further away, then an estimate time of completion (rather than time left) is
 397 given, and is identifiable by C<'ETA'> at the LHS of the ETA box (on the right
 398 of the progress bar).  A time or date may be presented; these are of the form
 399 of a 24 hour clock, e.g. C<'13:33'>, a time plus days (e.g., C<' 7PM+3'> for
 400 around in over 3 days time) or a day/date, e.g. C<' 1Jan'> or C<'27Feb'>.
 401
 402 If ETA is switched on, the return value of L<update|"update"> is also
 403 affected: the idea here is that if the progress bar seems to be moving quicker
 404 than the eye would normally care for (and thus a great deal of time is spent
 405 doing progress updates rather than "real" work), the next value is increased
 406 to slow it.  The maximum rate aimed for is tunable via the
 407 L<max_update_rate|"max_update_rate"> component.
 408
 409 The available values for this are:
 410
 411 =over 4
 412
 413 =item undef
 414
 415 Do not do estimation.  The default.
 416
 417 =item linear
 418
 419 Perform linear estimation.  This is simply that the amount of time between the
 420 creation of the progress bar and now is divided by the current amount done,
 421 and completion estimated linearly.
 422
 423 =back
 424
 425 =back
 426
 427 =item EXAMPLES
 428
 429   my $progress = Term::ProgressBar->new(100); # count from 1 to 100
 430   my $progress = Term::ProgressBar->new({ count => 100 }); # same
 431
 432   # Count to 200 thingies, outputting to stdout instead of stderr,
 433   # prefix bar with 'thingy'
 434   my $progress = Term::ProgressBar->new({ count => 200,
 435                                           fh    => \*STDOUT,
 436                                           name  => 'thingy' });
 437
 438 =back
 439
 440 =cut
 441
 442 Class::MethodMaker->import (new_with_init => 'new',
 443                             new_hash_init => 'hash_init',);
 444
 445 sub init {
 446   my $self = shift;
 447   return if $self->silent;
 448
 449   # V1 Compatibility
 450   return $self->init({count      => $_[1], name => $_[0],
 451                       term_width => 50,    bar_width => 50,
 452                       major_char => '#',   minor_char => '',
 453                       lbrack     => '',    rbrack     => '',
 454                       term       => '0 but true',
 455                       silent     => 0,})
 456     if @_ == 2;
 457
 458   my $target;
 459
 460   croak
 461     sprintf("Term::ProgressBar::new We don't handle this many arguments: %d",
 462             scalar @_)
 463     if @_ != 1;
 464
 465   my %config;
 466
 467   if ( UNIVERSAL::isa ($_[0], 'HASH') ) {
 468     ($target) = @{$_[0]}{qw(count)};
 469     %config = %{$_[0]}; # Copy in, so later playing does not tinker externally
 470   } else {
 471     ($target) = @_;
 472   }
 473
 474   if ( my @bad = grep ! exists DEFAULTS->{$_}, keys %config )  {
 475     croak sprintf("Input parameters (%s) to %s not recognized\n",
 476                   join(':', @bad), 'Term::ProgressBar::new');
 477   }
 478
 479   croak "Target count required for Term::ProgressBar new\n"
 480     unless defined $target;
 481
 482   $config{$_} = DEFAULTS->{$_}
 483     for grep ! exists $config{$_}, keys %{DEFAULTS()};
 484   delete $config{count};
 485
 486   $config{term} = -t $config{fh}
 487     unless defined $config{term};
 488
 489   if ( $__FORCE_TERM ) {
 490     $config{term} = 1;
 491     $config{term_width} = $__FORCE_TERM;
 492     die "term width $config{term_width} (from __force_term) too small"
 493       if $config{term_width} < 5;
 494   } elsif ( $config{term} and ! defined $config{term_width}) {
 495     $config{term_width} = $self->term_size($config{fh});
 496     die if $config{term_width} < 5;
 497   }
 498
 499   unless ( defined $config{bar_width} ) {
 500     if ( defined $config{term_width} ) {
 501       # 5 for the % marker
 502       $config{bar_width}  = $config{term_width} - 5;
 503       $config{bar_width} -= $_
 504         for map(( defined $config{$_} ? length($config{$_}) : 0),
 505                   qw( lbrack rbrack name ));
 506       $config{bar_width} -= 2 # Extra for ': '
 507         if defined $config{name};
 508       $config{bar_width} -= 10
 509         if defined $config{ETA};
 510       if ( $config{bar_width} < 1 ) {
 511         warn "terminal width $config{term_width} too small for bar; defaulting to 10\n";
 512         $config{bar_width} = 10;
 513       }
 514 #    } elsif ( ! $config{term} ) {
 515 #      $config{bar_width}  = 1;
 516 #      $config{term_width} = defined $config{ETA} ? 12 : 5;
 517     } else {
 518       $config{bar_width}  = $target;
 519       die "configured bar_width $config{bar_width} < 1"
 520       if $config{bar_width} < 1;
 521     }
 522   }
 523
 524   $config{start} = time;
 525
 526   select(((select $config{fh}), $| = 1)[0]);
 527
 528   $self->ETA(delete $config{ETA});
 529
 530   $self->hash_init (%config,
 531
 532                     offset        => 0,
 533                     scale         => 1,
 534
 535                     last_update   => 0,
 536                     last_position => 0,
 537                    );
 538   $self->target($target);
 539   $self->minor($config{term} && $target > $config{bar_width} ** 1.5);
 540
 541   $self->update(0); # Initialize the progress bar
 542 }
 543
 544
 545 # ----------------------------------
 546 # INSTANCE FINALIZATION
 547 # ----------------------------------
 548
 549 # ----------------------------------
 550 # INSTANCE COMPONENTS
 551 # ----------------------------------
 552
 553 =head1 INSTANCE COMPONENTS
 554
 555 =cut
 556
 557 =head2 Scalar Components.
 558
 559 See L<Class::MethodMaker/get_set> for usage.
 560
 561 =over 4
 562
 563 =item target
 564
 565 The final target.  Updates are measured in terms of this.  Changes will have
 566 no effect until the next update, but the next update value should be relative
 567 to the new target.  So
 568
 569   $p = Term::ProgressBar({count => 20});
 570   # Halfway
 571   $p->update(10);
 572   # Double scale
 573   $p->target(40)
 574   $p->update(21);
 575
 576 will cause the progress bar to update to 52.5%
 577
 578 =item max_update_rate
 579
 580 This value is taken as being the maximum speed between updates to aim for.
 581 B<It is only meaningful if ETA is switched on.> It defaults to 0.5, being the
 582 number of seconds between updates.
 583
 584 =back
 585
 586 =head2 Boolean Components
 587
 588 See L<Class::MethodMaker/get_set> for usage.
 589
 590 =over 4
 591
 592 =item minor
 593
 594 Default: set.  If unset, no minor scale will be calculated or updated.
 595
 596 Minor characters are used on the progress bar to give the user the idea of
 597 progress even when there are so many more tasks than the terminal is wide that
 598 the granularity would be too great.  By default, Term::ProgressBar makes a
 599 guess as to when minor characters would be valuable.  However, it may not
 600 always guess right, so this method may be called to force it one way or the
 601 other.  Of course, the efficiency saving is minimal unless the client is
 602 utilizing the return value of L<update|"update">.
 603
 604 See F<examples/powers4> and F<examples/powers3> to see minor characters in
 605 action, and not in action, respectively.
 606
 607 =back
 608
 609 =head2 Configuration
 610
 611 =over 4
 612
 613 =item lbrack
 614
 615 Left bracket ( defaults to [ )
 616
 617  $progress->lbrack('<');
 618
 619 =item rbrack
 620
 621 Right bracket ( defaults to ] )
 622
 623  $progress->rbrack('>');
 624
 625 =back
 626
 627 =cut
 628
 629 # Private Scalar Components
 630 #  offset    ) Default: 0.       Added to any value supplied to update.
 631 #  scale     ) Default: 1.       Any value supplied to update is multiplied by
 632 #                                this.
 633 #  major_char) Default: '='.     The character printed for the major scale.
 634 #  minor_char) Default: '*'.     The character printed for the minor scale.
 635 #  name      ) Default: undef.   The name to print to the side of the bar.
 636 #  fh        ) Default: STDERR.  The filehandle to output progress to.
 637
 638 # Private Counter Components
 639 #  last_update  ) Default: 0.    The so_far value last time update was invoked.
 640 #  last_position) Default: 0.    The number of the last progress mark printed.
 641
 642 # Private Boolean Components
 643 #  term      ) Default: detected (by C<Term::ReadKey>).
 644 #              If unset, we assume that we are not connected to a terminal (or
 645 #              at least, not a suitably intelligent one).  Then, we attempt
 646 #              minimal functionality.
 647
 648 Class::MethodMaker->import
 649   (
 650    get_set       => [qw/ major_units major_char
 651                          minor_units minor_char
 652                          lbrack      rbrack
 653                          name
 654                          offset      scale
 655                          fh          start
 656                          max_update_rate
 657                          silent
 658                      /],
 659    counter       => [qw/ last_position last_update /],
 660    boolean       => [qw/ minor name_printed pb_ended remove /],
 661    # let it be boolean to handle 0 but true
 662    get_set       => [qw/ term /],
 663   );
 664
 665 # We generate these by hand since we want to check the values.
 666 sub bar_width {
 667     my $self = shift;
 668     return if $self->silent;
 669     return $self->{bar_width} if not @_;
 670     croak 'wrong number of arguments' if @_ != 1;
 671     croak 'bar_width < 1' if $_[0] < 1;
 672     $self->{bar_width} = $_[0];
 673 }
 674 sub term_width {
 675     my $self = shift;
 676     return if $self->silent;
 677     return $self->{term_width} if not @_;
 678     croak 'wrong number of arguments' if @_ != 1;
 679     croak 'term_width must be at least 5' if $self->term and $_[0] < 5;
 680     $self->{term_width} = $_[0];
 681 }
 682
 683 sub target {
 684   my $self = shift;
 685   return if $self->silent;
 686
 687   if ( @_ ) {
 688     my ($target) = @_;
 689
 690     if ( $target ) {
 691       $self->major_units($self->bar_width / $target);
 692       $self->minor_units($self->bar_width ** 2 / $target);
 693       $self->minor      ( defined $self->term_width   and
 694                           $self->term_width < $target );
 695     }
 696     $self->{target}  = $target;
 697   }
 698
 699   return $self->{target};
 700 }
 701
 702 sub ETA {
 703   my $self = shift;
 704   return if $self->silent;
 705   if (@_) {
 706     my ($type) = @_;
 707     croak "Invalid ETA type: $type\n"
 708       if defined $type and ! exists ETA_TYPES->{$type};
 709     $self->{ETA} = $type;
 710   }
 711
 712   return $self->{ETA};
 713 }
 714
 715 # ----------------------------------
 716 # INSTANCE HIGHER-LEVEL FUNCTIONS
 717 # ----------------------------------
 718
 719 # ----------------------------------
 720 # INSTANCE HIGHER-LEVEL PROCEDURES
 721 # ----------------------------------
 722
 723 =head1 INSTANCE HIGHER-LEVEL PROCEDURES
 724
 725 Z<>
 726
 727 =cut
 728
 729 sub no_minor {
 730   warn sprintf("%s: This method is deprecated.  Please use %s instead\n",
 731                (caller (0))[3], '$x->minor (0)',);
 732   $_[0]->clear_minor (0);
 733 }
 734
 735 # -------------------------------------
 736
 737 =head2 update
 738
 739 Update the progress bar.
 740
 741 =over 4
 742
 743 =item ARGUMENTS
 744
 745 =over 4
 746
 747 =item so_far
 748
 749 Current progress point, in whatever units were passed to C<new>.
 750
 751 If not defined, assumed to be 1+ whatever was the value last time C<update>
 752 was called (starting at 0).
 753
 754 =back
 755
 756 =item RETURNS
 757
 758 =over 4
 759
 760 =item next_call
 761
 762 The next value of so_far at which to call C<update>.
 763
 764 =back
 765
 766 =back
 767
 768 =cut
 769
 770 sub update {
 771   my $self = shift;
 772   return if $self->silent;
 773   my ($so_far) = @_;
 774
 775   if ( ! defined $so_far ) {
 776     $so_far = $self->last_update + 1;
 777   }
 778
 779   my $input_so_far = $so_far;
 780   $so_far *= $self->scale
 781     unless $self->scale == 1;
 782   $so_far += $self->offset;
 783
 784   my $target = my $next = $self->target;
 785   my $name = $self->name;
 786   my $fh = $self->fh;
 787
 788   if ( $target < 1 ) {
 789     print $fh "\r";
 790     printf $fh "$name: "
 791       if defined $name;
 792     print $fh "(nothing to do)\n";
 793     return 2**32-1;
 794   }
 795
 796   my $biggies     = $self->major_units * $so_far;
 797   my @chars = (' ') x $self->bar_width;
 798   $chars[$_] = $self->major_char
 799     for 0..$biggies-1;
 800
 801   if ( $self->minor ) {
 802     my $smally      = $self->minor_units * $so_far % $self->bar_width;
 803     $chars[$smally] = $self->minor_char
 804       unless $so_far == $target;
 805     $next *= ($self->minor_units * $so_far + 1) / ($self->bar_width ** 2);
 806   } else {
 807     $next *= ($self->major_units * $so_far + 1) / $self->bar_width;
 808   }
 809
 810   local $\ = undef;
 811
 812   if ( $self->term > 0 ) {
 813     local $\ = undef;
 814     my $to_print = "\r";
 815     $to_print .= "$name: "
 816       if defined $name;
 817     my $ratio = $so_far / $target;
 818     # Rounds down %
 819     $to_print .= (sprintf ("%3d%% %s%s%s",
 820                         $ratio * 100,
 821                         $self->lbrack, join ('', @chars), $self->rbrack));
 822     my $ETA = $self->ETA;
 823     if ( defined $ETA and $ratio > 0 ) {
 824       if ( $ETA eq 'linear' ) {
 825         if ( $ratio == 1 ) {
 826           my $taken = time - $self->start;
 827           my $ss    = $taken % 60;
 828           my $mm    = int(($taken % 3600) / 60);
 829           my $hh    = int($taken / 3600);
 830           if ( $hh > 99 ) {
 831             $to_print .= sprintf('D %2dh%02dm', $hh, $mm, $ss);
 832           } else {
 833             $to_print .= sprintf('D%2dh%02dm%02ds', $hh, $mm, $ss);
 834           }
 835         } elsif ( $ratio < PREDICT_RATIO ) {
 836           # No safe prediction yet
 837           $to_print .= 'ETA ------';
 838         } else {
 839           my $time = time;
 840           my $left = (($time - $self->start) * ((1 - $ratio) / $ratio));
 841           if ( $left  < ETA_TIME_CUTOFF ) {
 842             $to_print .= sprintf '%1dm%02ds Left', int($left / 60), $left % 60;
 843           } else {
 844             my $eta  = $time + $left;
 845             my $format;
 846             if ( $left < DAY ) {
 847               $format = 'ETA  %H:%M';
 848             } elsif ( $left < ETA_DATE_CUTOFF ) {
 849               $format = sprintf('ETA %%l%%p+%d',$left/DAY);
 850             } else {
 851               $format = 'ETA %e%b';
 852             }
 853             $to_print .= strftime($format, localtime $eta);
 854           }
 855           # Calculate next to be at least SEC_PER_UPDATE seconds away
 856           if ( $left > 0 ) {
 857             my $incr = ($target - $so_far) / ($left / $self->max_update_rate);
 858             $next = $so_far + $incr
 859               if $so_far + $incr > $next;
 860           }
 861         }
 862       } else {
 863         croak "Bad ETA type: $ETA\n";
 864       }
 865     }
 866     for ($self->{last_printed}) {
 867         unless (defined and $_ eq $to_print) {
 868             print $fh $to_print;
 869         }
 870         $_ = $to_print;
 871     }
 872
 873     $next -= $self->offset;
 874     $next /= $self->scale
 875       unless $self->scale == 1;
 876
 877     if ( $so_far >= $target and $self->remove and ! $self->pb_ended) {
 878       print $fh "\r", ' ' x $self->term_width, "\r";
 879       $self->pb_ended;
 880     }
 881
 882   } else {
 883     local $\ = undef;
 884
 885     if ( $self->term ) { # special case for backwards compat.
 886      if ( $so_far == 0 and defined $name and ! $self->name_printed ) {
 887        print $fh "$name: ";
 888        $self->set_name_printed;
 889      }
 890
 891       my $position = int($self->bar_width * ($input_so_far / $target));
 892       my $add      = $position - $self->last_position;
 893       $self->last_position_incr ($add)
 894         if $add;
 895
 896      print $fh $self->major_char x $add;
 897
 898      $next -= $self->offset;
 899      $next /= $self->scale
 900        unless $self->scale == 1;
 901     } else {
 902       my $pc = int(100*$input_so_far/$target);
 903       printf $fh "[%s] %s: %3d%%\n", scalar(localtime), $name, $pc;
 904
 905       $next = ceil($target * ($pc+1)/100);
 906     }
 907
 908     if ( $input_so_far >= $target ) {
 909       if ( $self->pb_ended ) {
 910         croak ALREADY_FINISHED;
 911       } else {
 912         if ( $self->term ) {
 913           print $fh "\n"
 914         }
 915         $self->set_pb_ended;
 916       }
 917     }
 918   }
 919
 920
 921   $next = $target if $next > $target;
 922
 923   $self->last_update($input_so_far);
 924   return $next;
 925 }
 926
 927 # -------------------------------------
 928
 929 =head2 message
 930
 931 Output a message.  This is very much like print, but we try not to disturb the
 932 terminal.
 933
 934 =over 4
 935
 936 =item ARGUMENTS
 937
 938 =over 4
 939
 940 =item string
 941
 942 The message to output.
 943
 944 =back
 945
 946 =back
 947
 948 =cut
 949
 950 sub message {
 951   my $self = shift;
 952   return if $self->silent;
 953   my ($string) = @_;
 954   chomp ($string);
 955
 956   my $fh = $self->fh;
 957   local $\ = undef;
 958   if ( $self->term ) {
 959     print $fh "\r", ' ' x $self->term_width;
 960     print $fh "\r$string\n";
 961   } else {
 962     print $fh "\n$string\n";
 963     print $fh $self->major_char x $self->last_position;
 964   }
 965   undef $self->{last_printed};
 966   $self->update($self->last_update);
 967 }
 968
 969
 970 # ----------------------------------------------------------------------
 971
 972 =head1 REPORTING BUGS
 973
 974 via RT: L<https://rt.cpan.org/Dist/Display.html?Name=Pipe>
 975
 976 =head1 COMPATIBILITY
 977
 978 If exactly two arguments are provided, then L<new|"new"> operates in v1
 979 compatibility mode: the arguments are considered to be name, and item count.
 980 Various other defaults are set to emulate version one (e.g., the major output
 981 character is '#', the bar width is set to 50 characters and the output
 982 filehandle is not treated as a terminal). This mode is deprecated.
 983
 984 =head1 AUTHOR
 985
 986 Martyn J. Pearce fluffy@cpan.org
 987
 988 Significant contributions from Ed Avis, amongst others.
 989
 990 =head1 MAINTAINER
 991
 992 Gabor Szabo L<http://szabgab.com/>
 993
 994 =head1 COPYRIGHT
 995
 996 Copyright (c) 2001, 2002, 2003, 2004, 2005 Martyn J. Pearce.  This program is
 997 free software; you can redistribute it and/or modify it under the same terms
 998 as Perl itself.
 999
1000 =cut
1001
1002 1; # keep require happy.
1003
1004 __END__