import Term-ProgressBar-2.09 from CPAN
authorGabor Szabo <gabor@szabgab.com>
Tue, 29 Nov 2011 13:06:38 +0000 (15:06 +0200)
committerGabor Szabo <gabor@szabgab.com>
Tue, 29 Nov 2011 13:06:38 +0000 (15:06 +0200)
28 files changed:
BUGS [new file with mode: 0644]
Build.PL [new file with mode: 0644]
Changes [new file with mode: 0644]
INSTALL [new file with mode: 0644]
MANIFEST [new file with mode: 0644]
MANIFEST.SKIP [new file with mode: 0644]
META.yml [new file with mode: 0644]
Makefile.PL [new file with mode: 0644]
README [new file with mode: 0644]
SIGNATURE [new file with mode: 0644]
configure [new file with mode: 0644]
examples/powers [new file with mode: 0644]
examples/powers2 [new file with mode: 0644]
examples/powers3 [new file with mode: 0644]
examples/powers4 [new file with mode: 0644]
examples/powers5 [new file with mode: 0644]
lib/Term/ProgressBar.pm [new file with mode: 0644]
make-pm [new file with mode: 0644]
t/0-signature.t [new file with mode: 0644]
t/compat.t [new file with mode: 0644]
t/eta-linear.t [new file with mode: 0644]
t/name.t [new file with mode: 0644]
t/test.pm [new file with mode: 0644]
t/v1-message.t [new file with mode: 0644]
t/v2-message.t [new file with mode: 0644]
t/v2-mobile.t [new file with mode: 0644]
t/v2-simple.t [new file with mode: 0644]
t/zero.t [new file with mode: 0644]

diff --git a/BUGS b/BUGS
new file mode 100644 (file)
index 0000000..dfcda10
--- /dev/null
+++ b/BUGS
@@ -0,0 +1,2 @@
+001    1.50    Wrong minor character (= should be *) selected by default.
+       1.51    Fixed
\ No newline at end of file
diff --git a/Build.PL b/Build.PL
new file mode 100644 (file)
index 0000000..5fd8f84
--- /dev/null
+++ b/Build.PL
@@ -0,0 +1,15 @@
+use Module::Build 0.18;
+
+use File::Spec;
+
+my $build = Module::Build->new
+  (module_name   => 'Term::ProgressBar',
+   dist_version  => '2.09',
+   license       => 'perl',
+   requires      => {
+                     Class::MethodMaker => '1.02',
+                     Term::ReadKey      => '2.14',
+                    },
+  );
+
+$build->create_build_script
diff --git a/Changes b/Changes
new file mode 100644 (file)
index 0000000..122e0c5
--- /dev/null
+++ b/Changes
@@ -0,0 +1,63 @@
+Revision history for Perl extension Term-ProgressBar.
+
+2.09  Sun Mar 13  9:17 PM GMT 2005
+       - Fix for incorrect formatting of 'D...' time done at end
+
+2.08  Sat Mar 12 11:47 AM GMT 2005
+       - Add remove option
+       - Add patch to account for weird terminal sizing under Windoze
+         (thanks to Andrew Peters for the patch).
+
+2.07  Sun Mar  6  1:31 PM GMT 2005
+       - Correct handling of non-term mode to output stats but no PB
+       - Print time taken to complete in ETA mode when Done
+       - Add use of 'name' to example in 'new' doc
+       - Add doc of use of minor characters to description
+       - Add doc. for name value to new
+
+2.06  Sun Mar 14 10:46 AM GMT 2004
+       - Add patch to cope when terminal size cannot be detected or is
+         too small.  
+         Thanks to Ed Avis (<ed at membled dot com>) for the patch.
+       - Add patch to test to avoid failure on windoze due to unlinking open 
+         files
+       - Add patch to cope when Term::ReadKey fails to initialize for some 
+         reason.
+         Thanks to Scott Cain (<cain at cshl dot org>) for the patch.
+       - Add patch to suppress unnecessary terminal updates
+         Thanks to Ed Avis (<ed at membled dot com>) for the patch.
+
+2.05  Sat Aug 30  4:23 PM GMT 2003
+       - Fix test.pm to handle OS (e.g., Solaris) who refuse to delete the cwd
+
+2.04  Sat Aug 14  4:38 PM GMT 2003
+       - Change build system to accomodate CPAN & automated tests
+
+2.03  Sat Jan 11  3:47 PM GMT 2003
+       - Fix incorrect reset of progress bar in message method
+         Thanks to Frank Maas (<frank dot maas at cheiron-it dot nl>) for
+         the patch.
+       - Improve documentation of ETA display formats.
+
+2.02  Tue Nov 19 10:08 PM GMT 2002
+       - Fix behaviour in terminals where GetTerminalSize fails (e.g.,
+         resized Emacs term windows).  Thanks to Ed Avis for the patch.
+
+2.01  Mon Oct  7  9:12 PM GMT 2002
+       - Make it 5.005_03-compatible, with thanks to Ed Avis
+
+2.00  Sun Mar 10  5:26 AM GMT 2002
+       - New API added; now takes one hashref as argument (see docs)
+       - v1 API remains, but is deprecated
+       - Add message method to Term::ProgressBar
+       - Add v2 tests
+
+1.51  Sun Dec  2 12:22 PM GMT 2001
+       - Correct Bug #001
+
+1.50  Sat Dec  1  1:11 PM GMT 2001
+       - Merged with Utility::Progress by Martyn J. Pearce
+
+1.00  Mon Oct 30 2001
+       - original version
+       - by Edward Avis, <epa98 at sync32>
diff --git a/INSTALL b/INSTALL
new file mode 100644 (file)
index 0000000..66d6aec
--- /dev/null
+++ b/INSTALL
@@ -0,0 +1,21 @@
+To install this module, use
+
+  ./configure
+  make
+  make test
+  make install
+
+This will install using /usr/bin/perl .  If you wish to install using the perl
+in your PATH, use 'perl ./configure' instead of 'configure'.
+
+If you wish to install to a non-standard location, use 'configure
+--prefix=location' instead of 'configure'.
+
+So, to use the perl in your PATH to install to '/tmp', use
+
+  perl ./configure --prefix=/tmp
+  make
+  make test
+  make install
+
+Enjoy.
diff --git a/MANIFEST b/MANIFEST
new file mode 100644 (file)
index 0000000..8b8a54b
--- /dev/null
+++ b/MANIFEST
@@ -0,0 +1,28 @@
+Changes
+MANIFEST
+MANIFEST.SKIP
+README
+lib/Term/ProgressBar.pm
+t/compat.t
+Makefile.PL
+BUGS
+t/test.pm
+t/v2-message.t
+t/v2-simple.t
+t/v2-mobile.t
+t/name.t
+examples/powers
+examples/powers2
+examples/powers3
+examples/powers4
+examples/powers5
+t/eta-linear.t
+t/v1-message.t
+t/zero.t
+META.yml
+t/0-signature.t
+make-pm
+configure
+Build.PL
+SIGNATURE
+INSTALL
diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP
new file mode 100644 (file)
index 0000000..21cf8b6
--- /dev/null
@@ -0,0 +1,13 @@
+^(.*/)?CVS/.*
+^Makefile(.old)?$
+^Build$
+^Clean$
+^RollingBuild$
+^blib/.*
+^pm_to_blib$
+^(.*/)?.cvsignore$
+^MANIFEST.bak$
+^*~$
+^make[-.]pm$
+^INFO.yaml$
+^_build/
diff --git a/META.yml b/META.yml
new file mode 100644 (file)
index 0000000..e767152
--- /dev/null
+++ b/META.yml
@@ -0,0 +1,16 @@
+--- #YAML:1.0
+name: Term-ProgressBar
+version: 2.09
+license: perl
+distribution_type: module
+requires:
+  Class::MethodMaker: 1.02
+  Term::ReadKey: 2.14
+recommends: {}
+build_requires: {}
+conflicts: {}
+provides:
+  Term::ProgressBar:
+    file: lib/Term/ProgressBar.pm
+    version: 2.09
+generated_by: Module::Build version 0.21
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644 (file)
index 0000000..d227a21
--- /dev/null
@@ -0,0 +1,24 @@
+require 5.006;
+use strict;
+
+use ExtUtils::MakeMaker;
+
+WriteMakefile (
+  NAME         => 'Term-ProgressBar',
+  VERSION      => '2.09',
+  AUTHOR       => 'Martyn J. Pearce ',
+  ABSTRACT     => 'provide a progress meter on a standard terminal',
+  PREREQ_PM    => +{ 
+                     'Class::MethodMaker' => '1.02',
+                     'Term::ReadKey' => '2.14',},
+  EXE_FILES    => [qw(  )],
+  # Need this to stop Makefile treating Build.PL as a producer of Build as a
+  # target for 'all'.
+  PL_FILES     => +{},
+  clean        => +{ FILES => join(' ', qw( Build _build )) },
+  realclean    => +{ FILES => join(' ', qw( Build.PL META.yml
+                                            Makefile.PL
+                                            SIGNATURE
+                                            README INSTALL
+                                            configure make-pm )) },
+);
diff --git a/README b/README
new file mode 100644 (file)
index 0000000..a629fa2
--- /dev/null
+++ b/README
@@ -0,0 +1,38 @@
+Module Term-ProgressBar (2.09):
+
+Description:
+
+    A progress bar for things that take a while.  It looks like
+
+      50% [=====     ]
+
+    and is as long as the terminal.  Linear estimation of the time left for
+    the process to run is available.
+
+Modules & Classes Provided:
+
+    Term::ProgressBar - provide a progress meter on a standard terminal
+
+Required Packages:
+
+    Class::MethodMaker 1.02
+    Term::ReadKey      2.14
+
+Required Perl Version:
+
+    5.006
+
+Package Maintainer:
+
+    Martyn J. Pearce fluffy@cpan.org
+
+Copyright:
+
+    Copyright (c) 2005, 2004, 2003, 2002, 2001 Martyn J. Pearce.  This
+    program is free software; you can redistribute it and/or modify it
+    under the same terms as Perl itself.
+
+    Copyright (c) 2000 Ed Avis.  This program is free software; you can
+    redistribute it and/or modify it under the same terms as Perl itself.
+
+13th March, 2005
diff --git a/SIGNATURE b/SIGNATURE
new file mode 100644 (file)
index 0000000..7afe032
--- /dev/null
+++ b/SIGNATURE
@@ -0,0 +1,50 @@
+This file contains message digests of all files listed in MANIFEST,
+signed via the Module::Signature module, version 0.38.
+
+To verify the content in this distribution, first make sure you have
+Module::Signature installed, then type:
+
+    % cpansign -v
+
+It would check each file's integrity, as well as the signature's
+validity.  If "==> Signature verified OK! <==" is not displayed,
+the distribution may already have been compromised, and you should
+not run its Makefile.PL or Build.PL.
+
+-----BEGIN PGP SIGNED MESSAGE-----
+Hash: SHA1
+
+SHA1 308e635e1928d03e6c92ef224557847e18f492a6 BUGS
+SHA1 466429e1cefc8de46f7310bc7c64e6ac6af108e0 Build.PL
+SHA1 2cb916a845f60e44d62efe689de063d7bef20a99 Changes
+SHA1 efa8cb615886410be8de15f5a6925697f624d278 INSTALL
+SHA1 d0e591b2e5eafcc9a8de8ff9eda691fad5f85ffc MANIFEST
+SHA1 5c69f53a9cb6f5f717dd1d02266fc7c9f675a902 MANIFEST.SKIP
+SHA1 45fa692c1ad1ec954fe181c2d77b674f478a4201 META.yml
+SHA1 c88a83fd974fad3c16428163c87d3e6835296ae7 Makefile.PL
+SHA1 0de078a628603bf24ba4d01f2eb004360661be68 README
+SHA1 8f869f84e72c6fc7ac89ce26326bf981505be467 configure
+SHA1 8a4e566bff0ad33481975d55bcef13a9244bde16 examples/powers
+SHA1 cb478a1724ae1816e12511be593fd33517702413 examples/powers2
+SHA1 ff6df90436963b2b7e73f8ce6d6327f2dbcad1c3 examples/powers3
+SHA1 0fca941997cba7e66d39d4cec737ef09ee7df454 examples/powers4
+SHA1 37691f612074aa2fcea31c3b17c6ee46640f43db examples/powers5
+SHA1 cef7ba06dd315bf803d87ab7753ed7b92fb45818 lib/Term/ProgressBar.pm
+SHA1 37ba03162a46931b496a18413401d8f25b303cf1 make-pm
+SHA1 e7569e5eeef2a8558e6d4828be087a6e1a841295 t/0-signature.t
+SHA1 433e3ecad2aa8a7b3bb2f3766b17c195b33cbcc5 t/compat.t
+SHA1 f02bc46da7e3c83478c244adfad443f9c1a2b4ca t/eta-linear.t
+SHA1 f3b178ae1e9f1f1789443522ac861c8421f93eee t/name.t
+SHA1 037b2bf330c9ce722c1d122e4e561c610f4fee83 t/test.pm
+SHA1 ab36b1695c7ca9281da620347487bf88d02e66da t/v1-message.t
+SHA1 91f9f8f0765d5d7924c4c130934facb91eca6833 t/v2-message.t
+SHA1 87ecb3158e5eb9fe020c819e2d2f80ff8be45d92 t/v2-mobile.t
+SHA1 119b353912834b0040150a7094bf14425be03936 t/v2-simple.t
+SHA1 9048c3d6b67959e3cd598ac0e151daff435f39fe t/zero.t
+-----BEGIN PGP SIGNATURE-----
+Version: GnuPG v1.2.2 (Darwin)
+
+iD8DBQFCNK9oV6eZRcV4WK0RAlXrAKDKPgq5cPXM5PnlAh6a08MK0nUNpACdGd20
+54twrpUeCdFMSQoExw0HNrQ=
+=pBXe
+-----END PGP SIGNATURE-----
diff --git a/configure b/configure
new file mode 100644 (file)
index 0000000..5ec7005
--- /dev/null
+++ b/configure
@@ -0,0 +1,46 @@
+#!/usr/bin/perl -w
+
+use 5.006;
+use strict;
+
+use File::Spec        qw( );
+use Getopt::Long 2.19 qw( GetOptions );
+
+my $DEBUG;
+my $prefix;
+GetOptions ('debug'     => \$DEBUG,
+            'prefix=s'  => \$prefix,
+           )
+  or die "Options parsing failed";
+
+warn "Building with perl: $^X\n";
+
+use constant MOD_REQS =>
+  [
+    { name    => 'Class::MethodMaker',
+      version => '1.02',
+      
+    },
+  
+    { name    => 'Term::ReadKey',
+      version => '2.14',
+      package => 'TermReadKey',
+    },
+  
+  ];
+
+use constant EXEC_REQS => [ ];
+
+
+
+use constant NAME         => 'Term-ProgressBar';
+use constant VERSION_FROM =>
+  File::Spec->catfile(qw( lib Term ProgressBar.pm ));
+use constant AUTHOR       => 'Martyn J. Pearce ';
+use constant ABSTRACT     => 'provide a progress meter on a standard terminal';
+sub          PREFIX       {   $prefix }
+
+use FindBin 1.42 qw( $Bin );
+use lib $Bin;
+use lib '.';
+require 'make-pm';
diff --git a/examples/powers b/examples/powers
new file mode 100644 (file)
index 0000000..351abe9
--- /dev/null
@@ -0,0 +1,20 @@
+#!/usr/bin/perl
+
+use Term::ProgressBar 2.00;
+
+use constant MAX => 100_000;
+
+my $max = int($ARGV[0]+0) || MAX;
+my $progress = Term::ProgressBar->new($max);
+
+for (0..$max) {
+  my $is_power = 0;
+  for(my $i = 0; 2**$i <= $_; $i++) {
+    $is_power = 1
+      if 2**$i == $_;
+  }
+
+  if ( $is_power ) {
+    $progress->update($_);
+  }
+}
diff --git a/examples/powers2 b/examples/powers2
new file mode 100644 (file)
index 0000000..23147a0
--- /dev/null
@@ -0,0 +1,18 @@
+#!/usr/bin/perl
+
+use Term::ProgressBar 2.00;
+
+use constant MAX => 100_000;
+
+my $max = int($ARGV[0]+0) || MAX;
+my $progress = Term::ProgressBar->new($max);
+
+for (0..$max) {
+  my $is_power = 0;
+  for(my $i = 0; 2**$i <= $_; $i++) {
+    $is_power = 1
+      if 2**$i == $_;
+  }
+
+  $progress->update($_);
+}
diff --git a/examples/powers3 b/examples/powers3
new file mode 100644 (file)
index 0000000..82ae224
--- /dev/null
@@ -0,0 +1,23 @@
+#!/usr/bin/perl
+
+use Term::ProgressBar 2.00;
+
+use constant MAX => 100_000;
+
+my $max = int($ARGV[0]+0) || MAX;
+my $progress = Term::ProgressBar->new({name => 'Powers', count => $max, remove => 3});
+$progress->minor(0);
+my $next_update = 0;
+
+for (0..$max) {
+  my $is_power = 0;
+  for(my $i = 0; 2**$i <= $_; $i++) {
+    $is_power = 1
+      if 2**$i == $_;
+  }
+
+  $next_update = $progress->update($_)
+    if $_ > $next_update;
+}
+$progress->update($max)
+    if $max >= $next_update;
diff --git a/examples/powers4 b/examples/powers4
new file mode 100644 (file)
index 0000000..ad9353e
--- /dev/null
@@ -0,0 +1,26 @@
+#!/usr/bin/perl
+
+use Term::ProgressBar 2.00;
+
+use constant MAX => 1_000_000;
+
+my $max = int($ARGV[0]+0) || MAX;
+my $progress = Term::ProgressBar->new({name => 'Powers', count => $max,
+                                       ETA => linear, });
+#$progress->minor(0);
+my $next_update = 0;
+
+for (0..$max) {
+  my $is_power = 0;
+  for(my $i = 0; 2**$i <= $_; $i++) {
+    $is_power = 1
+      if 2**$i == $_;
+  }
+sleep 1
+if $_ % 4 == 0;
+
+  $next_update = $progress->update($_)
+    if $_ > $next_update;
+}
+$progress->update($max)
+    if $max >= $next_update;
diff --git a/examples/powers5 b/examples/powers5
new file mode 100644 (file)
index 0000000..bc0c310
--- /dev/null
@@ -0,0 +1,26 @@
+#!/usr/bin/perl
+
+use Term::ProgressBar 2.00;
+
+use constant MAX => 10_000_000;
+
+my $max = int($ARGV[0]+0) || MAX;
+my $progress = Term::ProgressBar->new({name => 'Powers', count => $max,
+                                       ETA => linear, });
+$progress->max_update_rate(1);
+my $next_update = 0;
+
+for (0..$max) {
+  my $is_power = 0;
+  for(my $i = 0; 2**$i <= $_; $i++) {
+    if ( 2**$i == $_ ) {
+      $is_power = 1;
+      $progress->message(sprintf "Found %8d to be 2 ** %2d", $_, $i);
+    }
+  }
+
+  $next_update = $progress->update($_)
+    if $_ > $next_update;
+}
+$progress->update($max)
+    if $max >= $next_update;
diff --git a/lib/Term/ProgressBar.pm b/lib/Term/ProgressBar.pm
new file mode 100644 (file)
index 0000000..f1ed1dc
--- /dev/null
@@ -0,0 +1,959 @@
+# (X)Emacs mode: -*- cperl -*-
+
+package Term::ProgressBar;
+
+#XXX TODO Redo original test with count=20
+#         Amount Output
+#         Amount Prefix/Suffix
+#         Tinker with $0?
+#         Test use of last_update (with update(*undef*)) with scales
+#         Choice of FH other than STDERR
+#         If no term, output no progress bar; just progress so far
+#         Use of simple term with v2.0 bar
+#         If name is wider than term, trim name
+#         Don't update progress bar on new?
+
+=head1 NAME
+
+Term::ProgressBar - provide a progress meter on a standard terminal
+
+=head1 SYNOPSIS
+
+  use Term::ProgressBar;
+
+  $progress = Term::ProgressBar->new ({count => $count});
+  $progress->update ($so_far);
+
+=head1 DESCRIPTION
+
+Term::ProgressBar provides a simple progress bar on the terminal, to let the
+user know that something is happening, roughly how much stuff has been done,
+and maybe an estimate at how long remains.
+
+A typical use sets up the progress bar with a number of items to do, and then
+calls L<update|"update"> to update the bar whenever an item is processed.
+
+Often, this would involve updating the progress bar many times with no
+user-visible change.  To avoid uneccessary work, the update method returns a
+value, being the update value at which the user will next see a change.  By
+only calling update when the current value exceeds the next update value, the
+call overhead is reduced.
+
+Remember to call the C<< $progress->update($max_value) >> when the job is done
+to get a nice 100% done bar.
+
+A progress bar by default is simple; it just goes from left-to-right, filling
+the bar with '=' characters.  These are called B<major> characters.  For
+long-running jobs, this may be too slow, so two additional features are
+available: a linear completion time estimator, and/or a B<minor> character:
+this is a character that I<moves> from left-to-right on the progress bar (it
+does not fill it as the major character does), traversing once for each
+major-character added.  This exponentially increases the granularity of the
+bar for the same width.
+
+=head1 EXAMPLES
+
+=head2 A really simple use
+
+  #!/usr/bin/perl
+
+  use Term::ProgressBar 2.00;
+
+  use constant MAX => 100_000;
+
+  my $progress = Term::ProgressBar->new(MAX);
+
+  for (0..MAX) {
+    my $is_power = 0;
+    for(my $i = 0; 2**$i <= $_; $i++) {
+      $is_power = 1
+        if 2**$i == $_;
+    }
+
+    if ( $is_power ) {
+      $progress->update($_);
+    }
+  }
+
+Here is a simple example.  The process considers all the numbers between 0 and
+MAX, and updates the progress bar whenever it finds one.  Note that the
+progress bar update will be very erratic.  See below for a smoother example.
+Note also that the progress bar will never complete; see below to solve this.
+
+The complete text of this example is in F<examples/powers> in the
+distribution set (it is not installed as part of the module).
+
+=head2 A smoother bar update
+
+  my $progress = Term::ProgressBar->new($max);
+
+  for (0..$max) {
+    my $is_power = 0;
+    for(my $i = 0; 2**$i <= $_; $i++) {
+      $is_power = 1
+        if 2**$i == $_;
+    }
+
+    $progress->update($_)
+  }
+
+This example calls update for each value considered.  This will result in a
+much smoother progress update, but more program time is spent updating the bar
+than doing the "real" work.  See below to remedy this.  This example does
+I<not> call C<< $progress->update($max); >> at the end, since it is
+unnecessary, and ProgressBar will throw an exception at an attempt to update a
+finished bar.
+
+The complete text of this example is in F<examples/powers2> in the
+distribution set (it is not installed as part of the module.
+
+=head2 A (much) more efficient update
+
+  my $progress = Term::ProgressBar->new({name => 'Powers', count => $max, remove => 1});
+  $progress->minor(0);
+  my $next_update = 0;
+
+  for (0..$max) {
+    my $is_power = 0;
+    for(my $i = 0; 2**$i <= $_; $i++) {
+      $is_power = 1
+        if 2**$i == $_;
+    }
+
+    $next_update = $progress->update($_)
+      if $_ >= $next_update;
+  }
+  $progress->update($max)
+    if $max >= $next_update;
+
+This example does two things to improve efficiency: firstly, it uses the value
+returned by L<update|"update"> to only call it again when needed; secondly, it
+switches off the use of minor characters to update a lot less frequently (C<<
+$progress->minor(0); >>.  The use of the return value of L<update|"update">
+means that the call of C<< $progress->update($max); >> at the end is required
+to ensure that the bar ends on 100%, which gives the user a nice feeling.
+
+This example also sets the name of the progress bar.
+
+This example also demonstrates the use of the 'remove' flag, which removes the
+progress bar from the terminal when done.
+
+The complete text of this example is in F<examples/powers3> in the
+distribution set (it is not installed as part of the module.
+
+=head2 Using Completion Time Estimation
+
+  my $progress = Term::ProgressBar->new({name  => 'Powers',
+                                         count => $max,
+                                         ETA   => linear, });
+  $progress->max_update_rate(1);
+  my $next_update = 0;
+
+  for (0..$max) {
+    my $is_power = 0;
+    for(my $i = 0; 2**$i <= $_; $i++) {
+      if ( 2**$i == $_ ) {
+        $is_power = 1;
+        $progress->message(sprintf "Found %8d to be 2 ** %2d", $_, $i);
+      }
+    }
+
+    $next_update = $progress->update($_)
+      if $_ > $next_update;
+  }
+  $progress->update($max)
+      if $max >= $next_update;
+
+This example uses the L<ETA|"ETA"> option to switch on completion estimation.
+Also, the update return is tuned to try to update the bar approximately once
+per second, with the L<max_update_rate|"max_update_rate"> call.  See the
+documentation for the L<new|new> method for details of the format(s) used.
+
+This example also provides an example of the use of the L<message|"message">
+function to output messages to the same filehandle whilst keeping the progress bar intact
+
+The complete text of this example is in F<examples/powers5> in the
+distribution set (it is not installed as part of the module.
+
+=cut
+
+# ----------------------------------------------------------------------
+
+# Pragmas --------------------------
+
+use strict;
+
+# Inheritance ----------------------
+
+use base qw( Exporter );
+use vars '@EXPORT_OK';
+@EXPORT_OK = qw( $PACKAGE $VERSION );
+
+# Utility --------------------------
+
+use Carp                    qw( croak );
+use Class::MethodMaker 1.02 qw( );
+use Fatal                   qw( open sysopen close seek );
+use POSIX                   qw( ceil strftime );
+
+# ----------------------------------------------------------------------
+
+# CLASS METHODS --------------------------------------------------------
+
+# ----------------------------------
+# CLASS CONSTANTS
+# ----------------------------------
+
+=head1 CLASS CONSTANTS
+
+Z<>
+
+=cut
+
+use constant MINUTE => 60;
+use constant HOUR   => 60 * MINUTE;
+use constant DAY    => 24 * HOUR;
+
+# The point past which to give ETA of just date, rather than time
+use constant ETA_DATE_CUTOFF => 3 * DAY;
+# The point past which to give ETA of time, rather time left
+use constant ETA_TIME_CUTOFF => 10 * MINUTE;
+# The ratio prior to which to not dare any estimates
+use constant PREDICT_RATIO => 0.01;
+
+use constant DEFAULTS => {
+                          lbrack     => '[',
+                          rbrack     => ']',
+                          minor_char => '*',
+                          major_char => '=',
+                          fh         => \*STDERR,
+                          name       => undef,
+                          ETA        => undef,
+                          max_update_rate => 0.5,
+
+                          # The following defaults are never used, but the keys
+                          # are valuable for error checking
+                          count      => undef,
+                          bar_width  => undef,
+                          term_width => undef,
+                          term       => undef,
+                          remove     => 0,
+                         };
+
+use constant ETA_TYPES => { map { $_ => 1 } qw( linear ) };
+
+use constant ALREADY_FINISHED => 'progress bar already finished';
+
+use constant DEBUG => 0;
+
+# -------------------------------------
+
+use vars qw($PACKAGE $VERSION);
+$PACKAGE = 'Term-ProgressBar';
+$VERSION = '2.09';
+
+# ----------------------------------
+# CLASS CONSTRUCTION
+# ----------------------------------
+
+# ----------------------------------
+# CLASS COMPONENTS
+# ----------------------------------
+
+# This is here to allow testing to redirect away from the terminal but still
+# see terminal output, IYSWIM
+my $__FORCE_TERM = 0;
+
+# ----------------------------------
+# CLASS HIGHER-LEVEL FUNCTIONS
+# ----------------------------------
+
+# ----------------------------------
+# CLASS HIGHER-LEVEL PROCEDURES
+# ----------------------------------
+
+sub __force_term {
+  my $class = shift;
+  ($__FORCE_TERM) = @_;
+}
+
+# ----------------------------------
+# CLASS UTILITY FUNCTIONS
+# ----------------------------------
+
+sub term_size {
+  my ($fh) = @_;
+
+  eval {
+    require Term::ReadKey;
+  }; if ($@) {
+    warn "Guessing terminal width due to problem with Term::ReadKey\n";
+    return 50;
+  }
+
+  my $result;
+  eval {
+    $result = (Term::ReadKey::GetTerminalSize($fh))[0];
+    $result-- if ($^O eq "MSWin32");
+  }; if ( $@ ) {
+    warn "error from Term::ReadKey::GetTerminalSize(): $@";
+  }
+
+  # If GetTerminalSize() failed it should (according to its docs)
+  # return an empty list.  It doesn't - that's why we have the eval {}
+  # above - but also it may appear to succeed and return a width of
+  # zero.
+  #
+  if ( ! $result ) {
+    $result = 50;
+    warn "guessing terminal width $result\n";
+  }
+
+  return $result;
+}
+
+
+# INSTANCE METHODS -----------------------------------------------------
+
+# ----------------------------------
+# INSTANCE CONSTRUCTION
+# ----------------------------------
+
+=head1 INSTANCE CONSTRUCTION
+
+Z<>
+
+=cut
+
+# Don't document hash keys until tested that the give the desired affect!
+
+=head2 new
+
+Create & return a new Term::ProgressBar instance.
+
+=over 4
+
+=item ARGUMENTS
+
+If one argument is provided, and it is a hashref, then the hash is treated as
+a set of key/value pairs, with the following keys; otherwise, it is treated as
+a number, being equivalent to the C<count> key.
+
+=over 4
+
+=item count
+
+The item count.  The progress is marked at 100% when update I<count> is
+invoked, and proportionally until then.
+
+=item name
+
+A name to prefix the progress bar with.
+
+=item fh
+
+The filehandle to output to.  Defaults to stderr.  Do not try to use
+*foo{THING} syntax if you want Term capabilities; it does not work.  Pass in a
+globref instead.
+
+=item ETA
+
+A total time estimation to use.  If enabled, a time finished estimation is
+printed on the RHS (once sufficient updates have been performed to make such
+an estimation feasible).  Naturally, this is an I<estimate>; no guarantees are
+made.  The format of the estimate
+
+Note that the format is intended to be as compact as possible while giving
+over the relevant information.  Depending upon the time remaining, the format
+is selected to provide some resolution whilst remaining compact.  Since the
+time remaining decreases, the format typically changes over time.
+
+As the ETA approaches, the format will state minutes & seconds left.  This is
+identifiable by the word C<'Left'> at the RHS of the line.  If the ETA is
+further away, then an estimate time of completion (rather than time left) is
+given, and is identifiable by C<'ETA'> at the LHS of the ETA box (on the right
+of the progress bar).  A time or date may be presented; these are of the form
+of a 24 hour clock, e.g. C<'13:33'>, a time plus days (e.g., C<' 7PM+3'> for
+around in over 3 days time) or a day/date, e.g. C<' 1Jan'> or C<'27Feb'>.
+
+If ETA is switched on, the return value of L<update|"update"> is also
+affected: the idea here is that if the progress bar seems to be moving quicker
+than the eye would normally care for (and thus a great deal of time is spent
+doing progress updates rather than "real" work), the next value is increased
+to slow it.  The maximum rate aimed for is tunable via the
+L<max_update_rate|"max_update_rate"> component.
+
+The available values for this are:
+
+=over 4
+
+=item undef
+
+Do not do estimation.  The default.
+
+=item linear
+
+Perform linear estimation.  This is simply that the amount of time between the
+creation of the progress bar and now is divided by the current amount done,
+and completion estimated linearly.
+
+=back
+
+=back
+
+=item EXAMPLES
+
+  my $progress = Term::ProgressBar->new(100); # count from 1 to 100
+  my $progress = Term::ProgressBar->new({ count => 100 }); # same
+
+  # Count to 200 thingies, outputting to stdout instead of stderr,
+  # prefix bar with 'thingy'
+  my $progress = Term::ProgressBar->new({ count => 200,
+                                          fh    => \*STDOUT,
+                                          name  => 'thingy' });
+
+=back
+
+=cut
+
+Class::MethodMaker->import (new_with_init => 'new',
+                            new_hash_init => 'hash_init',);
+
+sub init {
+  my $self = shift;
+
+  # V1 Compatibility
+  return $self->init({count      => $_[1], name => $_[0],
+                      term_width => 50,    bar_width => 50,
+                      major_char => '#',   minor_char => '',
+                      lbrack     => '',    rbrack     => '',
+                      term       => '0 but true', })
+    if @_ == 2;
+
+  my $target;
+
+  croak
+    sprintf("Term::ProgressBar::new We don't handle this many arguments: %d",
+            scalar @_)
+    if @_ != 1;
+
+  my %config;
+
+  if ( UNIVERSAL::isa ($_[0], 'HASH') ) {
+    ($target) = @{$_[0]}{qw(count)};
+    %config = %{$_[0]}; # Copy in, so later playing does not tinker externally
+  } else {
+    ($target) = @_;
+  }
+
+  if ( my @bad = grep ! exists DEFAULTS->{$_}, keys %config )  {
+    croak sprintf("Input parameters (%s) to %s not recognized\n",
+                  join(':', @bad), 'Term::ProgressBar::new');
+  }
+
+  croak "Target count required for Term::ProgressBar new\n"
+    unless defined $target;
+
+  $config{$_} = DEFAULTS->{$_}
+    for grep ! exists $config{$_}, keys %{DEFAULTS()};
+  delete $config{count};
+
+  $config{term} = -t $config{fh}
+    unless defined $config{term};
+
+  if ( $__FORCE_TERM ) {
+    $config{term} = 1;
+    $config{term_width} = $__FORCE_TERM;
+    die "term width $config{term_width} (from __force_term) too small"
+      if $config{term_width} < 5;
+  } elsif ( $config{term} and ! defined $config{term_width}) {
+    $config{term_width} = term_size($config{fh});
+    die if $config{term_width} < 5;
+  }
+
+  unless ( defined $config{bar_width} ) {
+    if ( defined $config{term_width} ) {
+      # 5 for the % marker
+      $config{bar_width}  = $config{term_width} - 5;
+      $config{bar_width} -= $_
+        for map(( defined $config{$_} ? length($config{$_}) : 0),
+                  qw( lbrack rbrack name ));
+      $config{bar_width} -= 2 # Extra for ': '
+        if defined $config{name};
+      $config{bar_width} -= 10
+        if defined $config{ETA};
+      if ( $config{bar_width} < 1 ) {
+        warn "terminal width $config{term_width} too small for bar; defaulting to 10\n";
+        $config{bar_width} = 10;
+      }
+#    } elsif ( ! $config{term} ) {
+#      $config{bar_width}  = 1;
+#      $config{term_width} = defined $config{ETA} ? 12 : 5;
+    } else {
+      $config{bar_width}  = $target;
+      die "configured bar_width $config{bar_width} < 1"
+       if $config{bar_width} < 1;
+    }
+  }
+
+  $config{start} = time;
+
+  select(((select $config{fh}), $| = 1)[0]);
+
+  $self->ETA(delete $config{ETA});
+
+  $self->hash_init (%config,
+
+                    offset        => 0,
+                    scale         => 1,
+
+                    last_update   => 0,
+                    last_position => 0,
+                   );
+  $self->target($target);
+  $self->minor($config{term} && $target > $config{bar_width} ** 1.5);
+
+  $self->update(0); # Initialize the progress bar
+}
+
+
+# ----------------------------------
+# INSTANCE FINALIZATION
+# ----------------------------------
+
+# ----------------------------------
+# INSTANCE COMPONENTS
+# ----------------------------------
+
+=head1 INSTANCE COMPONENTS
+
+=cut
+
+=head2 Scalar Components.
+
+See L<Class::MethodMaker/get_set> for usage.
+
+=over 4
+
+=item target
+
+The final target.  Updates are measured in terms of this.  Changes will have
+no effect until the next update, but the next update value should be relative
+to the new target.  So
+
+  $p = Term::ProgressBar({count => 20});
+  # Halfway
+  $p->update(10);
+  # Double scale
+  $p->target(40)
+  $p->update(21);
+
+will cause the progress bar to update to 52.5%
+
+=item max_update_rate
+
+This value is taken as being the maximum speed between updates to aim for.
+B<It is only meaningful if ETA is switched on.> It defaults to 0.5, being the
+number of seconds between updates.
+
+=back
+
+=head2 Boolean Components
+
+See L<Class::MethodMaker/get_set> for usage.
+
+=over 4
+
+=item minor
+
+Default: set.  If unset, no minor scale will be calculated or updated.
+
+Minor characters are used on the progress bar to give the user the idea of
+progress even when there are so many more tasks than the terminal is wide that
+the granularity would be too great.  By default, Term::ProgressBar makes a
+guess as to when minor characters would be valuable.  However, it may not
+always guess right, so this method may be called to force it one way or the
+other.  Of course, the efficiency saving is minimal unless the client is
+utilizing the return value of L<update|"update">.
+
+See F<examples/powers4> and F<examples/powers3> to see minor characters in
+action, and not in action, respectively.
+
+=back
+
+=cut
+
+# Private Scalar Components
+#  offset    ) Default: 0.       Added to any value supplied to update.
+#  scale     ) Default: 1.       Any value supplied to update is multiplied by
+#                                this.
+#  major_char) Default: '='.     The character printed for the major scale.
+#  minor_char) Default: '*'.     The character printed for the minor scale.
+#  name      ) Default: undef.   The name to print to the side of the bar.
+#  fh        ) Default: STDERR.  The filehandle to output progress to.
+
+# Private Counter Components
+#  last_update  ) Default: 0.    The so_far value last time update was invoked.
+#  last_position) Default: 0.    The number of the last progress mark printed.
+
+# Private Boolean Components
+#  term      ) Default: detected (by C<Term::ReadKey>).
+#              If unset, we assume that we are not connected to a terminal (or
+#              at least, not a suitably intelligent one).  Then, we attempt
+#              minimal functionality.
+
+Class::MethodMaker->import
+  (
+   get_set       => [qw/ major_units major_char
+                         minor_units minor_char
+                         lbrack      rbrack
+                         name
+                         offset      scale
+                         fh          start
+                         max_update_rate
+                     /],
+   counter       => [qw/ last_position last_update /],
+   boolean       => [qw/ minor name_printed pb_ended remove /],
+   # let it be boolean to handle 0 but true
+   get_set       => [qw/ term /],
+  );
+
+# We generate these by hand since we want to check the values.
+sub bar_width {
+    my $self = shift;
+    return $self->{bar_width} if not @_;
+    croak 'wrong number of arguments' if @_ != 1;
+    croak 'bar_width < 1' if $_[0] < 1;
+    $self->{bar_width} = $_[0];
+}
+sub term_width {
+    my $self = shift;
+    return $self->{term_width} if not @_;
+    croak 'wrong number of arguments' if @_ != 1;
+    croak 'term_width must be at least 5' if $self->term and $_[0] < 5;
+    $self->{term_width} = $_[0];
+}
+
+sub target {
+  my $self = shift;
+
+  if ( @_ ) {
+    my ($target) = @_;
+
+    if ( $target ) {
+      $self->major_units($self->bar_width / $target);
+      $self->minor_units($self->bar_width ** 2 / $target);
+      $self->minor      ( defined $self->term_width   and
+                          $self->term_width < $target );
+    }
+    $self->{target}  = $target;
+  }
+
+  return $self->{target};
+}
+
+sub ETA {
+  my $self = shift;
+
+  if (@_) {
+    my ($type) = @_;
+    croak "Invalid ETA type: $type\n"
+      if defined $type and ! exists ETA_TYPES->{$type};
+    $self->{ETA} = $type;
+  }
+
+  return $self->{ETA};
+}
+
+# ----------------------------------
+# INSTANCE HIGHER-LEVEL FUNCTIONS
+# ----------------------------------
+
+# ----------------------------------
+# INSTANCE HIGHER-LEVEL PROCEDURES
+# ----------------------------------
+
+=head1 INSTANCE HIGHER-LEVEL PROCEDURES
+
+Z<>
+
+=cut
+
+sub no_minor {
+  warn sprintf("%s: This method is deprecated.  Please use %s instead\n",
+               (caller (0))[3], '$x->minor (0)',);
+  $_[0]->clear_minor (0);
+}
+
+# -------------------------------------
+
+=head2 update
+
+Update the progress bar.
+
+=over 4
+
+=item ARGUMENTS
+
+=over 4
+
+=item so_far
+
+Current progress point, in whatever units were passed to C<new>.
+
+If not defined, assumed to be 1+ whatever was the value last time C<update>
+was called (starting at 0).
+
+=back
+
+=item RETURNS
+
+=over 4
+
+=item next_call
+
+The next value of so_far at which to call C<update>.
+
+=back
+
+=back
+
+=cut
+
+sub update {
+  my $self = shift;
+  my ($so_far) = @_;
+
+  if ( ! defined $so_far ) {
+    $so_far = $self->last_update + 1;
+  }
+
+  my $input_so_far = $so_far;
+  $so_far *= $self->scale
+    unless $self->scale == 1;
+  $so_far += $self->offset;
+
+  my $target = my $next = $self->target;
+  my $name = $self->name;
+  my $fh = $self->fh;
+
+  if ( $target < 1 ) {
+    print $fh "\r";
+    printf $fh "$name: "
+      if defined $name;
+    print $fh "(nothing to do)\n";
+    return 2**32-1;
+  }
+
+  my $biggies     = $self->major_units * $so_far;
+  my @chars = (' ') x $self->bar_width;
+  $chars[$_] = $self->major_char
+    for 0..$biggies-1;
+
+  if ( $self->minor ) {
+    my $smally      = $self->minor_units * $so_far % $self->bar_width;
+    $chars[$smally] = $self->minor_char
+      unless $so_far == $target;
+    $next *= ($self->minor_units * $so_far + 1) / ($self->bar_width ** 2);
+  } else {
+    $next *= ($self->major_units * $so_far + 1) / $self->bar_width;
+  }
+
+  local $\ = undef;
+
+  if ( $self->term > 0 ) {
+    local $\ = undef;
+    my $to_print = "\r";
+    $to_print .= "$name: "
+      if defined $name;
+    my $ratio = $so_far / $target;
+    # Rounds down %
+    $to_print .= (sprintf ("%3d%% %s%s%s",
+                        $ratio * 100,
+                        $self->lbrack, join ('', @chars), $self->rbrack));
+    my $ETA = $self->ETA;
+    if ( defined $ETA and $ratio > 0 ) {
+      if ( $ETA eq 'linear' ) {
+        if ( $ratio == 1 ) {
+          my $taken = time - $self->start;
+          my $ss    = $taken % 60;
+          my $mm    = int(($taken % 3600) / 60);
+          my $hh    = int($taken / 3600);
+          if ( $hh > 99 ) {
+            $to_print .= sprintf('D %2dh%02dm', $hh, $mm, $ss);
+          } else {
+            $to_print .= sprintf('D%2dh%02dm%02ds', $hh, $mm, $ss);
+          }
+        } elsif ( $ratio < PREDICT_RATIO ) {
+          # No safe prediction yet
+          $to_print .= 'ETA ------';
+        } else {
+          my $time = time;
+          my $left = (($time - $self->start) * ((1 - $ratio) / $ratio));
+          if ( $left  < ETA_TIME_CUTOFF ) {
+            $to_print .= sprintf '%1dm%02ds Left', int($left / 60), $left % 60;
+          } else {
+            my $eta  = $time + $left;
+            my $format;
+            if ( $left < DAY ) {
+              $format = 'ETA  %H:%M';
+            } elsif ( $left < ETA_DATE_CUTOFF ) {
+              $format = sprintf('ETA %%l%%p+%d',$left/DAY);
+            } else {
+              $format = 'ETA %e%b';
+            }
+            $to_print .= strftime($format, localtime $eta);
+          }
+          # Calculate next to be at least SEC_PER_UPDATE seconds away
+          if ( $left > 0 ) {
+            my $incr = ($target - $so_far) / ($left / $self->max_update_rate);
+            $next = $so_far + $incr
+              if $so_far + $incr > $next;
+          }
+        }
+      } else {
+        croak "Bad ETA type: $ETA\n";
+      }
+    }
+    for ($self->{last_printed}) {
+       unless (defined and $_ eq $to_print) {
+           print $fh $to_print;
+       }
+       $_ = $to_print;
+    }
+
+    $next -= $self->offset;
+    $next /= $self->scale
+      unless $self->scale == 1;
+
+    if ( $so_far >= $target and $self->remove and ! $self->pb_ended) {
+      print $fh "\r", ' ' x $self->term_width, "\r";
+      $self->pb_ended;
+    }
+
+  } else {
+    local $\ = undef;
+
+    if ( $self->term ) { # special case for backwards compat.
+     if ( $so_far == 0 and defined $name and ! $self->name_printed ) {
+       print $fh "$name: ";
+       $self->set_name_printed;
+     }
+
+      my $position = int($self->bar_width * ($input_so_far / $target));
+      my $add      = $position - $self->last_position;
+      $self->last_position_incr ($add)
+        if $add;
+
+     print $fh $self->major_char x $add;
+
+     $next -= $self->offset;
+     $next /= $self->scale
+       unless $self->scale == 1;
+    } else {
+      my $pc = int(100*$input_so_far/$target);
+      printf $fh "[%s] %s: %3d%%\n", scalar(localtime), $name, $pc;
+
+      $next = ceil($target * ($pc+1)/100);
+    }
+
+    if ( $input_so_far >= $target ) {
+      if ( $self->pb_ended ) {
+        croak ALREADY_FINISHED;
+      } else {
+        if ( $self->term ) {
+          print $fh "\n"
+        }
+        $self->set_pb_ended;
+      }
+    }
+  }
+
+
+  $next = $target if $next > $target;
+
+  $self->last_update($input_so_far);
+  return $next;
+}
+
+# -------------------------------------
+
+=head2 message
+
+Output a message.  This is very much like print, but we try not to disturb the
+terminal.
+
+=over 4
+
+=item ARGUMENTS
+
+=over 4
+
+=item string
+
+The message to output.
+
+=back
+
+=back
+
+=cut
+
+sub message {
+  my $self = shift;
+  my ($string) = @_;
+  chomp ($string);
+
+  my $fh = $self->fh;
+  local $\ = undef;
+  if ( $self->term ) {
+    print $fh "\r", ' ' x $self->term_width;
+    print $fh "\r$string\n";
+  } else {
+    print $fh "\n$string\n";
+    print $fh $self->major_char x $self->last_position;
+  }
+  undef $self->{last_printed};
+  $self->update($self->last_update);
+}
+
+
+# ----------------------------------------------------------------------
+
+=head1 BUGS
+
+Z<>
+
+=head1 REPORTING BUGS
+
+Email the author.
+
+=head1 COMPATIBILITY
+
+If exactly two arguments are provided, then L<new|"new"> operates in v1
+compatibility mode: the arguments are considered to be name, and item count.
+Various other defaults are set to emulate version one (e.g., the major output
+character is '#', the bar width is set to 50 characters and the output
+filehandle is not treated as a terminal). This mode is deprecated.
+
+=head1 AUTHOR
+
+Martyn J. Pearce fluffy@cpan.org
+
+Significant contributions from Ed Avis, amongst others.
+
+=head1 COPYRIGHT
+
+Copyright (c) 2001, 2002, 2003, 2004, 2005 Martyn J. Pearce.  This program is
+free software; you can redistribute it and/or modify it under the same terms
+as Perl itself.
+
+=head1 SEE ALSO
+
+Z<>
+
+=cut
+
+1; # keep require happy.
+
+__END__
diff --git a/make-pm b/make-pm
new file mode 100644 (file)
index 0000000..b84051a
--- /dev/null
+++ b/make-pm
@@ -0,0 +1,538 @@
+# (X)Emacs mode: -*- cperl -*-
+
+use 5.005;
+use strict;
+
+=head1 NAME
+
+make - tools for making makefiles with.
+
+=head1 SYNOPSIS
+
+  use constant MOD_REQS =>
+    [
+     { name    => 'Pod::Usage',
+       version => '1.12', },
+
+     { name    => 'IPC::Run',
+       package => 'IPC-Run',
+       version => '0.44', },
+
+     { name     => 'DBI::Wrap',
+       package  => 'DBI-Wrap',
+       version  => '1.00',
+       optional => 1, },
+    ];
+
+  use constant EXEC_REQS =>
+    [
+     { name    => 'blastpgp',
+       version => '1.50',
+       vopt    => '--version', },
+
+     { name    => 'mkprofile', },
+
+     { name    => 'mp3id',
+       version => '0.4',
+       vopt    => '--help',
+       vexpect => 255, },
+    ];
+
+  use constant NAME         => 'Module-Name';
+  use constant VERSION_FROM => catfile (qw( lib Module Name.pm ));
+  use constant AUTHOR       => 'Martyn J. Pearce fluffy@cpan.org';
+  use constant ABSTRACT     => 'This module makes chocolate biscuits';
+
+  use make.pm
+
+=head1 DESCRIPTION
+
+This package provides methods and initialization to build standard perl
+modules.
+
+The plan is, you define the requirements, and let the module take care of the
+rest.
+
+The requirements you must define are:
+
+=over 4
+
+=item MOD_REQS
+
+An arrayref of hashrefs.  Each hashref represents a required Perl module, and
+has the following keys:
+
+=over 4
+
+=item name
+
+B<Mandatory> Name of the module used.  The presence of this module is checked,
+and an exception is raised if it does not exist.
+
+=item package
+
+B<Optional> Name of the package in which the module is to be found.  If not
+defined, the package is assumed to be present in core Perl.
+
+Modules that have been in core Perl since 5.005 need not be listed; the "core
+perl" default is for modules such as C<Pod::Usage> which have been added to
+the core since 5.005.
+
+=item version
+
+B<Optional> If supplied, the version of the module is checked against this
+number, and an exception raised if the version found is lower than that
+requested.
+
+=item optional
+
+B<Optional> If true, then failure to locate the package (or a suitable
+version) is not an error, but will generate a warning message.
+
+=item message
+
+If supplied, then this message will be given to the user in case of failure.
+
+=back
+
+=item EXEC_REQS
+
+=over 4
+
+=item name
+
+Name of the executable used.  The presence of this executable is checked, and
+an exception is raised if it does not exist (in the PATH).
+
+=item package
+
+B<Optional> Name of the package in which the executable is to be found.
+
+=item version
+
+B<Optional> If supplied, the version of the module is checked against this
+number, and an exception raised if the version found is lower than that
+requested.
+
+If supplied, the L<vopt> key must also be supplied.
+
+=item vopt
+
+B<Optional> This is used only if the C<version> key is also used.  This is the
+option that is passed to the executable to ask for its version number.  It may
+be the empty string if no option is used (but must be defined if C<version> is
+defined).
+
+=item vexpect
+
+B<Optional> This is used only if the C<version> key is also used.  This is the
+exit code to expect from the program when polling for its version number.
+Defaults to 0.  This is the exit code (value of C<$?> in the shell) to use,
+I<not> the value of the C<wait> call.
+
+=item optional
+
+B<Optional> If true, then failure to locate the package (or a suitable
+version) is not an error, but will generate a warning message.
+
+=item message
+
+If supplied, then this message will be given to the user in case of failure.
+
+=back
+
+=item NAME
+
+The module name.  It must conform to the established standard; in particular,
+it must B<not> contain colon characters.  The usual process, when providing a
+single-package module (e.g., to provide C<MIME::Base64>), is to replace the
+C<::> occurences with hyphens (hence, C<MIME-Base64>).
+
+=item VERSION_FROM
+
+The module from which to establish the version number.  This module must have
+a line of the form C<$VERSION = '0.01';>.  Declarative prefixes (.e.g, C<our>)
+are fine; C<our> is the usual one, since C<$VERSION> is almost always a
+package variable.
+
+=item AUTHOR
+
+The name of the module author(s), along with an email address.  This is
+normally the person primarily responsible for the upkeep of the module.
+
+=item ABSTRACT
+
+A single (concise!) sentence describing the rough purpose of the module.  It
+is not expected to be mightily accurate, but is for quick browsing of modules.
+
+=item DEPENDS
+
+I<Optional>
+
+If defined, this must be an arrayref of additional targets to insert into
+F<Makefile>.  Each element must be a hashref, with the following keys:
+
+=over 4
+
+=item target
+
+Name of the rule target
+
+=item reqs
+
+Arrayref of rule requisites
+
+=item rules
+
+Arrayref of rule lines.  Do not precede these with a tab character; this will
+be inserted for you.  Likewise, do not break the lines up.
+
+=back
+
+E.g.,
+
+  use constant DEPENDS      => [
+                                { target => 'lib/Class/MethodMaker.pm',
+                                  reqs   => [qw/ cmmg.pl /],
+                                  rules  => [ '$(PERL) $< > $@' ],
+                                },
+                               ];
+
+=item DERIVED_PM
+
+I<Optional>.  If defined, this is expected to be an arrayref of file names
+(relative to the dist base), that are pm files to be installed.
+
+By default, F<make.pm> finds the pms to install by a conducting a C<find> over
+the F<lib> directory when C<perl Makefile.PL> is run.  However, for pm files
+that are created, that will be insufficient.  By specifying extras with this
+constant, such files may be named (and therefore made), and also cleaned when
+a C<make clean> is issued.  This might well be used in conjunction with the
+L<DEPENDS|"DEPENDS"> constant to auto-make pm files.
+
+E.g.,
+
+  use constant DERIVED_PM     => [qw( lib/Class/MethodMaker.pm )];
+
+=cut
+
+use Config                   qw( %Config );
+use ExtUtils::MakeMaker      qw( WriteMakefile );
+use File::Find               qw( find );
+use File::Spec               qw( );
+sub catfile { File::Spec->catfile(@_) }
+
+
+# Constants ---------------------------
+
+use constant TYPE_EXEC => 'executable';
+use constant TYPE_MOD  => 'module';
+use constant TYPES     => [ TYPE_EXEC, TYPE_MOD ];
+
+use constant CONFIG =>
+  {
+   TYPE_MOD  , { defaults => { package => 'core perl',
+                             },
+                 find     => sub { eval "require $_[0]"; $@ eq '' },
+                 vers     => sub {
+                   no strict 'refs';
+                   # Fool emacs indenter
+                   my $_x = q={=; my $pv = ${"$_[0]::VERSION"};
+                   return defined $pv ? $pv : -1;
+                 },
+               },
+   TYPE_EXEC , { defaults => { vexpect => 0, },
+                 find     => sub {
+                   my ($name) = @_;
+                   my $exec;
+                 PATH_COMPONENT:
+                   for my $path (split /:/, $ENV{PATH}) {
+                     my $try = catfile $path, $name;
+                     if ( -x $try ) {
+                       $exec = $try;
+                       last PATH_COMPONENT;
+                     }
+                   }
+                   defined $exec;
+                 },
+                 vers     => sub {
+                   my ($name, $vopt, $expect) = @_;
+                   die "Cannot test version of $name without vopt\n"
+                     unless defined $vopt;
+                   my $cmd = join ' ', $name, $vopt;
+                   my $vstr = qx($cmd 2>&1);
+                   my $rv = $? >> 8;
+                   die sprintf "Command $cmd exited with value: $rv\n"
+                     if $rv != $expect;
+                   if ( $vstr =~ /(?:^|\D)v?(\d+(?:[._]\d+)+)(?![\d_.])/ ) {
+                     (my $version = $1) =~ tr/_/./;
+                     return $version;
+                   } else {
+                     return -1;
+                   }
+                 },
+               },
+  };
+
+# Subrs ----------------------------------------------------------------------
+
+sub warn_missing {
+  my ($missing) = @_;
+
+  my ($type_max) = sort { $b <=> $a } map length $_->{type}, @$missing;
+  my ($name_max) = sort { $b <=> $a } map length $_->{name}, @$missing;
+
+  for (@$missing) {
+    my ($type, $name, $pkg, $vers, $pv, $optional, $message) =
+      @{$_}{qw( type name package vers_req vers_fnd optional message )};
+
+    if ( defined $pv ) {
+      print STDERR sprintf("%-${type_max}s %${name_max}s requires version " .
+                           "$vers (found $pv)",
+                           $type, $name)
+    } else {
+      print STDERR sprintf("Couldn't find %${type_max}s %${name_max}s",
+                           $type, $name);
+    }
+
+    print STDERR " (from $pkg)"
+      if defined $pkg;
+    print STDERR "\n";
+
+    print STDERR "  ...but this isn't fatal\n"
+      if $optional;
+
+    if ( defined $message ) {
+      $message =~ s/(^|\n)/$1    /g;
+      $message =~ s/([^\n])$/$1\n/;
+      print STDERR "\n";
+      print STDERR $message;
+      print STDERR "\n";
+    }
+  }
+}
+
+# -------------------------------------
+
+sub check {
+  my ($items, $verbose) = @_;
+
+  my ($type_max) = sort { $b <=> $a } map length, @{TYPES()};
+  my ($name_max) = sort { $b <=> $a } map length($_->{name}), @$items;
+
+  my @missing;
+
+  foreach my $item (@$items) {
+    my $type = $item->{type};
+    my $defaults = CONFIG->{$type}->{defaults};
+    $item->{$_} = $defaults->{$_}
+      for grep ! exists $item->{$_}, keys %$defaults;
+    my ($name, $pkg, $vers, $vopt, $vexpect) =
+      @{$item}{qw( name package version vopt vexpect)};
+
+    printf STDERR "Checking for %-${type_max}s %-${name_max}s...", $type, $name
+      if $verbose;
+    if ( CONFIG->{$type}->{find}->($name) ) {
+      print STDERR " found\n"
+        if $verbose;
+
+      if ( defined $vers ) {
+        my $vfound = CONFIG->{$type}->{vers}->($name, $vopt, $vexpect);
+        my $str_v_reqd  = join '_', map sprintf('%09d',$_), split /\./,$vers;
+        my $str_v_found = join '_', map sprintf('%09d',$_), split /\./,$vfound;
+        push @missing, { type     => $type,
+                         name     => $name,
+                         package  => $pkg,
+                         vers_req => $vers,
+                         vers_fnd => $vfound,
+                         optional => $item->{optional},
+                         message  => $item->{message},
+                       }
+          if $str_v_reqd gt $str_v_found;
+      }
+    } else {
+      print STDERR " failed\n"
+        if $verbose;
+      push @missing, { type     => $type,
+                       name     => $name,
+                       package  => $pkg,
+                       vers_req => $vers,
+                       optional => $item->{optional},
+                       message  => $item->{message},
+                     };
+    }
+  }
+
+  return @missing;
+}
+
+# Main -----------------------------------------------------------------------
+
+# Self Test
+
+if ( $ENV{MAKE_SELF_TEST} ) {
+  # Find Module (no version)
+  check([{ name => 'integer' , type => TYPE_MOD, }])
+    and die "Internal Check (1) failed\n";
+  # Fail module (no version)
+  check([{ name => 'flubble' , type => TYPE_MOD, }])
+    or die "Internal Check (2) failed\n";
+  # Find module, wrong version
+  check([{ name => 'IO'      , type => TYPE_MOD, version => '100.0', }])
+    or die "Internal Check (3) failed\n";
+  # Find module, right version
+  check([{ name => 'IO'      , type => TYPE_MOD, version => '1.00',  }])
+    and die "Internal Check (4) failed\n";
+
+  # Find exec (no version)
+    # Use more (common to dog/windoze too!) (mac?)
+  check([{ name => 'more'    , type => TYPE_EXEC, }])
+    and die "Internal Check (5) failed\n";
+  # Fail exec (no version)
+  check([{ name => ' wibwib' , type => TYPE_EXEC, }])
+    or die "Internal Check (6) failed\n";
+
+  # Could do with one that works on dog/windoze/mac...
+  if ( $Config{osname} eq 'linux' ) {
+    # Find exec, wrong version
+    check([{ name => 'cut'     , type => TYPE_EXEC,
+             version => '100.0', vopt => '--version', }])
+      or die "Internal Check (7) failed\n";
+    # Find exec, right version
+    check([{ name => 'cut'     , type => TYPE_EXEC,
+             version => '1.0', vopt => '--version', }])
+      and die "Internal Check (8) failed\n";
+  }
+}
+# -------------------------------------
+
+my @missing;
+
+{
+  no strict 'refs';
+  die "$_ not defined\n"
+    for grep ! defined *$_{CODE}, qw( MOD_REQS EXEC_REQS
+                                      NAME VERSION_FROM AUTHOR ABSTRACT );
+}
+
+die sprintf(<<'END', NAME) unless NAME =~ /^[A-Za-z0-9-]+$/;
+The module name:%s: is illegal (letters, numbers & hyphens only, please)
+END
+
+$_->{type} = TYPE_MOD
+  for @{MOD_REQS()};
+$_->{type} = TYPE_EXEC
+  for @{EXEC_REQS()};
+
+push @missing, check(MOD_REQS, 1), check(EXEC_REQS, 1);
+
+warn_missing(\@missing);
+
+exit 2
+  for grep ! $_->{optional}, @missing;
+
+my %pm;
+find (sub {
+        $File::Find::prune = 1, return
+          if -d $_ and $_ eq 'CVS';
+        return unless /\.pm$/;
+        (my $target = $File::Find::name) =~
+          s/^$File::Find::topdir/\$(INST_LIBDIR)/;
+        $pm{$File::Find::name} = $target;
+      },
+      'lib');
+
+sub MY::postamble {
+  <<EOF;
+check: test
+EOF
+}
+
+my %Config =
+  (NAME         => NAME,
+   VERSION_FROM => VERSION_FROM,
+   AUTHOR       => AUTHOR,
+   ABSTRACT     => ABSTRACT,
+   PREREQ_PM    => { map (($_->{name} => $_->{version} || 0 ),
+                          grep ! $_->{optional}, @{MOD_REQS()})},
+   PM           => \%pm,
+   # Need this to stop Makefile treating Build.PL as a producer of Build as a
+   # target for 'all'.
+   PL_FILES     => +{},
+   EXE_FILES    => [ grep !/(?:CVS|~)$/, glob catfile (qw( bin * )) ],
+   clean        => +{ FILES => [qw( Build _build )] },
+   realclean    => +{ FILES => [qw( Build.PL META.yml
+                                    INSTALL
+                                    SIGNATURE
+                                    make-pm )] },
+  );
+
+$Config{PREFIX} = *PREFIX{CODE}->()
+  if defined *PREFIX{CODE};
+push @{$Config{clean}->{FILES}}, @{*EXTRA_CLEAN{CODE}->()}
+  if defined *EXTRA_CLEAN{CODE};
+push @{$Config{realclean}->{FILES}}, qw( Makefile.PL configure README )
+  if -e 'INFO.yaml';
+
+if ( defined *DEPENDS{CODE} ) {
+  my $depends = *DEPENDS{CODE}->();
+  my %depends;
+  for (@$depends) {
+    my ($target) = $_->{target};
+    my ($reqs)   = $_->{reqs};
+    my ($rules)  = $_->{rules};
+
+    $depends{$target} = join("\n\t", join(' ', @$reqs), @$rules) . "\n";
+  }
+  $Config{depend} = \%depends;
+}
+
+if ( defined *DERIVED_PM{CODE} ) {
+  my $extra = *DERIVED_PM{CODE}->();
+  die sprintf "Don't know how to handle type: %s\n", ref $extra
+    unless UNIVERSAL::isa($extra, 'ARRAY');
+
+  for (@$extra) {
+    $Config{PM}->{catfile('lib', $_)} = catfile '$(INST_LIBDIR)', $_;
+    push @{$Config{clean}->{FILES}}, $_;
+  }
+}
+
+$Config{clean}->{FILES}     = join ' ', @{$Config{clean}->{FILES}};
+$Config{realclean}->{FILES} = join ' ', @{$Config{realclean}->{FILES}};
+
+WriteMakefile (%Config);
+
+# ----------------------------------------------------------------------------
+
+=head1 EXAMPLES
+
+Z<>
+
+=head1 BUGS
+
+Z<>
+
+=head1 REPORTING BUGS
+
+Email the author.
+
+=head1 AUTHOR
+
+Martyn J. Pearce C<fluffy@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2001, 2002, 2003 Martyn J. Pearce.  This program is free
+software; you can redistribute it and/or modify it under the same terms as
+Perl itself.
+
+=head1 SEE ALSO
+
+Z<>
+
+=cut
+
+1; # keep require happy
+
+__END__
diff --git a/t/0-signature.t b/t/0-signature.t
new file mode 100644 (file)
index 0000000..9de4488
--- /dev/null
@@ -0,0 +1,16 @@
+#!/usr/bin/perl
+use strict;
+print "1..1\n";
+
+if ( ! eval { require Module::Signature; 1 } ) {
+  print("ok 1 # skip ",
+        "Next time around, consider install Module::Signature, ",
+        "# so you can verify the integrity of this distribution.\n");
+} elsif ( ! eval { require Socket; Socket::inet_aton('pgp.mit.edu') } ) {
+  print "ok 1 # skip ", "Cannot connect to the keyserver\n";
+} else {
+  (Module::Signature::verify() == Module::Signature::SIGNATURE_OK())
+    or print "not ";
+  print "ok 1 # Valid signature\n";
+}
+
diff --git a/t/compat.t b/t/compat.t
new file mode 100644 (file)
index 0000000..9aa8efc
--- /dev/null
@@ -0,0 +1,136 @@
+# (X)Emacs mode: -*- cperl -*-
+
+use strict;
+
+=head1 Unit Test Package for Term::ProgressBar v1.0 Compatibility
+
+This script is based on the test script for Term::ProgressBar version 1.0,
+and is intended to test compatibility with that version.
+
+=cut
+
+# Utility -----------------------------
+
+use Data::Dumper qw( );
+use Test qw( ok plan );
+
+# Test Setup --------------------------
+
+BEGIN {
+  plan tests => 5,
+       todo  => [],
+       ;
+}
+
+# -------------------------------------
+
+# grab_output()
+#
+# Eval some code and return what was printed to stdout and stderr.
+#
+# Parameters: string of code to eval
+#
+# Returns: listref of [ stdout text, stderr text ]
+#
+sub grab_output($) {
+    die 'usage: grab_stderr(string to eval)' if @_ != 1;
+    my $code = shift;
+    require POSIX;
+    my $tmp_o = POSIX::tmpnam(); my $tmp_e = POSIX::tmpnam();
+    local (*OLDOUT, *OLDERR);
+
+    # Try to get a message to the outside world if we die
+    local $SIG{__DIE__} = sub { print $_[0]; die $_[0] };
+
+    open(OLDOUT, ">&STDOUT") or die "can't dup stdout: $!";
+    open(OLDERR, ">&STDERR") or die "can't dup stderr: $!";
+    open(STDOUT, ">$tmp_o")  or die "can't open stdout to $tmp_o: $!";
+    open(STDERR, ">$tmp_e")  or die "can't open stderr to $tmp_e: $!";
+    eval $code;
+    # Doubtful whether most of these messages will ever be seen!
+    close(STDOUT)            or die "cannot close stdout opened to $tmp_o: $!";
+    close(STDERR)            or die "cannot close stderr opened to $tmp_e: $!";
+    open(STDOUT, ">&OLDOUT") or die "can't dup stdout back again: $!";
+    open(STDERR, ">&OLDERR") or die "can't dup stderr back again: $!";
+
+    die $@ if $@;
+
+    local $/ = undef;
+    open (TMP_O, $tmp_o) or die "cannot open $tmp_o: $!";
+    open (TMP_E, $tmp_e) or die "cannot open $tmp_e: $!";
+    my $o = <TMP_O>; my $e = <TMP_E>;
+    close TMP_O   or die "cannot close filehandle opened to $tmp_o: $!";
+    close TMP_E   or die "cannot close filehandle opened to $tmp_e: $!";
+    unlink $tmp_o or die "cannot unlink $tmp_o: $!";
+    unlink $tmp_e or die "cannot unlink $tmp_e: $!";
+
+    return [ $o, $e ];
+}
+
+# Change 1..1 below to 1..last_test_to_print .
+# (It may become useful if the test is moved to ./t subdirectory.)
+
+use Term::ProgressBar;
+use POSIX qw<floor ceil>;
+
+=head2 Test 1: compilation
+
+This test confirms that the test script and the modules it calls compiled
+successfully.
+
+=cut
+
+ok 1, 1, 'compilation';
+
+# -------------------------------------
+
+$| = 1;
+
+my $count = 100;
+
+# Test 2: create a bar
+my $test_str = 'test';
+
+use vars '$b';
+my $o = grab_output("\$b = new Term::ProgressBar '$test_str', $count");
+if (not $b or $o->[0] ne '' or $o->[1] ne "$test_str: ") {
+    print Data::Dumper->Dump([$b, $o], [qw( b o )])
+      if $ENV{TEST_DEBUG};
+    print 'not ';
+}
+print "ok 2\n";
+
+# Test 3: do half the stuff and check half the bar has printed
+my $halfway = floor($count / 2);
+$o = grab_output("update \$b foreach (0 .. $halfway - 1)");
+if ($o->[0] ne ''
+    or $o->[1] ne ('#' x floor(50 / 2)) )
+{
+    print Data::Dumper->Dump([$o], [qw( o )])
+      if $ENV{TEST_DEBUG};
+    print 'not ';
+}
+print "ok 3\n";
+
+# Test 4: do the rest of the stuff and check the whole bar has printed
+$o = grab_output("update \$b foreach ($halfway .. $count - 1)");
+if ($o->[0] ne ''
+    or $o->[1] ne ('#' x ceil(50 / 2)) . "\n" )
+{
+    print Data::Dumper->Dump([$o], [qw( o )])
+      if $ENV{TEST_DEBUG};
+    print 'not ';
+}
+print "ok 4\n";
+
+# Test 5: try to do another item and check there is an error
+eval { update $b };
+unless ( defined($@)
+         and
+         (substr($@, 0, length(Term::ProgressBar::ALREADY_FINISHED))
+          eq Term::ProgressBar::ALREADY_FINISHED) ) {
+  print Data::Dumper->Dump([$@], [qw( @ )])
+    if $ENV{TEST_DEBUG};
+  print 'not ';
+}
+print "ok 5\n";
diff --git a/t/eta-linear.t b/t/eta-linear.t
new file mode 100644 (file)
index 0000000..25081ee
--- /dev/null
@@ -0,0 +1,86 @@
+# (X)Emacs mode: -*- cperl -*-
+
+use strict;
+
+=head1 Unit Test Package for Term::ProgressBar
+
+This package tests the basic functionality of Term::ProgressBar.
+
+=cut
+
+use Data::Dumper  qw( Dumper );
+use FindBin       qw( $Bin );
+use Test          qw( ok plan );
+
+use lib $Bin;
+use test qw( DATA_DIR
+             evcheck restore_output save_output );
+
+BEGIN {
+  # 1 for compilation test,
+  plan tests  => 10,
+       todo   => [],
+}
+
+=head2 Test 1: compilation
+
+This test confirms that the test script and the modules it calls compiled
+successfully.
+
+=cut
+
+use Term::ProgressBar;
+
+ok 1, 1, 'compilation';
+
+Term::ProgressBar->__force_term (50);
+
+# -------------------------------------
+
+=head2 Tests 2--10: Count 1-10
+
+Create a progress bar with 10 things.  Invoke ETA and name on it.
+Update it it from 1 to 10.
+
+(1) Check no exception thrown on creation
+(2) Check no exception thrown on update 1..5
+(3) Check no exception thrown on message issued
+(4) Check no exception thrown on update 6..10
+(5) Check message seen
+(6) Check bar is complete
+(7) Check bar number is 100%
+(8) Check --DONE-- issued
+(9) Check estimation done
+
+=cut
+
+{
+  my $p;
+  save_output('stderr', *STDERR{IO});
+  ok (evcheck(sub {
+                $p = Term::ProgressBar->new({count => 10, name => 'fred',
+                                             ETA => 'linear'});
+              }, 'Count 1-10 (1)' ),
+      1, 'Count 1-10 (1)');
+  ok (evcheck(sub { for (1..5) { $p->update($_); sleep 1 } },
+              'Count 1-10 (2)' ),
+      1, 'Count 1-10 (2)');
+  ok (evcheck(sub { $p->message('Hello Mum!') },
+              'Count 1-10 (3)' ),
+      1, 'Count 1-10 (3)');
+  ok (evcheck(sub { for (6..10) { $p->update($_); sleep 1 } },
+              'Count 1-10 (4)' ),
+      1, 'Count 1-10 (4)');
+  my $err = restore_output('stderr');
+#  $err =~ s!^.*\r!!gm;
+  my @lines = grep $_ ne '', split /[\n\r]+/, $err;
+  print Dumper \@lines
+    if $ENV{TEST_DEBUG};
+  ok grep $_ eq 'Hello Mum!', @lines;
+  ok $lines[-1], qr/\[=+\]/,                                  'Count 1-10 (6)';
+  ok $lines[-1], qr/^fred: \s*100%/,                          'Count 1-10 (7)';
+  ok $lines[-1], qr/D[ \d]\dh\d{2}m\d{2}s$/,                  'Count 1-10 (8)';
+  ok $lines[-2], qr/ Left$/,                                  'Count 1-10 (9)';
+}
+
+# ----------------------------------------------------------------------------
diff --git a/t/name.t b/t/name.t
new file mode 100644 (file)
index 0000000..9b68576
--- /dev/null
+++ b/t/name.t
@@ -0,0 +1,169 @@
+# (X)Emacs mode: -*- cperl -*-
+
+use strict;
+
+=head1 Unit Test Package for Term::ProgressBar
+
+This package tests the name functionality of Term::ProgressBar.
+
+=cut
+
+use Data::Dumper  qw( Dumper );
+use FindBin       qw( $Bin );
+use Test          qw( ok plan );
+
+use lib $Bin;
+use test qw( DATA_DIR
+             evcheck restore_output save_output );
+
+use constant MESSAGE1 => 'The Gospel of St. Jude';
+use constant NAME1    => 'Algenon';
+use constant NAME2    => 'Smegma';
+
+BEGIN {
+  # 1 for compilation test,
+  plan tests  => 18,
+       todo   => [],
+}
+
+=head2 Test 1: compilation
+
+This test confirms that the test script and the modules it calls compiled
+successfully.
+
+=cut
+
+use Term::ProgressBar;
+
+ok 1, 1, 'compilation';
+
+Term::ProgressBar->__force_term (50);
+
+# -------------------------------------
+
+=head2 Tests 2--10: Count 1-10
+
+Create a progress bar with 10 things, and a name 'Algenon'.
+Update it it from 1 to 10.
+
+(1) Check no exception thrown on creation
+(2) Check no exception thrown on update (1..3)
+(3) Check bar number is 30%
+(4) Check bar is 30% along
+(5) Check no exception thrown on message send
+(6) Check no exception thrown on update (6..10)
+(7) Check message seen
+(8) Check bar is complete
+(9) Check bar number is 100%
+
+=cut
+
+{
+  my $p;
+  save_output('stderr', *STDERR{IO});
+  ok (evcheck(sub {
+                $p = Term::ProgressBar->new({count => 10, name => NAME1});
+              },                                            'Count 1-10 ( 1)'),
+      1,                                                    'Count 1-10 ( 1)');
+  ok (evcheck(sub { $p->update($_) for 1..3  },             'Count 1-10 ( 2)'),
+      1,                                                    'Count 1-10 ( 2)');
+
+  my $err = restore_output('stderr');
+
+  $err =~ s!^.*\r!!gm;
+  print STDERR "ERR (1) :\n$err\nlength: ", length($err), "\n"
+    if $ENV{TEST_DEBUG};
+  my @lines = split /\n/, $err;
+  ok $lines[-1], qr/^@{[NAME1()]}: \s*\b30%/,                'Count 1-10 ( 3)';
+  my ($bar, $space) = $lines[-1] =~ /\[(=*)(\s*)\]/;
+  my $length = length($bar) + length($space);
+  print STDERR
+    ("LENGTHS (1) :BAR:", length($bar), ":SPACE:", length($space), "\n")
+    if $ENV{TEST_DEBUG};
+  my $barexpect = $length * 0.3;
+  my $ok = length($bar) > $barexpect -1 && length($bar) < $barexpect+1;
+  ok $ok;
+
+  save_output('stderr', *STDERR{IO});
+
+  ok (evcheck(sub { $p->message(MESSAGE1)    },             'Count 1-10 ( 5)'),
+      1,                                                    'Count 1-10 ( 5)');
+  ok (evcheck(sub { $p->update($_) for 6..10 },             'Count 1-10 ( 6)'),
+      1,                                                    'Count 1-10 ( 6)');
+  $err = restore_output('stderr');
+
+  $err =~ s!^.*\r!!gm;
+  print STDERR "ERR (2) :\n$err\nlength: ", length($err), "\n"
+    if $ENV{TEST_DEBUG};
+
+  @lines = split /\n/, $err;
+
+  ok $lines[0], MESSAGE1,                                    'Count 1-10 ( 7)';
+  ok $lines[-1], qr/\[=+\]/,                                 'Count 1-10 ( 8)';
+  ok $lines[-1], qr/^@{[NAME1()]}: \s*100%/,                 'Count 1-10 ( 9)';
+}
+
+# -------------------------------------
+
+=head2 Tests 11--20: Count 1-20
+
+Create a progress bar with 20 things, and a name 'Smegma'.
+Update it it from 1 to 20.
+Use v1 mode
+
+(1) Check no exception thrown on creation
+(2) Check no exception thrown on update (1..12)
+(3) Check bar number is 60%
+(4) Check bar is 60% along
+(5) Check no exception thrown on message send
+(6) Check no exception thrown on update (13..20)
+(7) Check message seen
+(8) Check bar is complete
+(9) Check bar number is 100%
+
+=cut
+
+{
+  my $p;
+  save_output('stderr', *STDERR{IO});
+  ok (evcheck(sub { $p = Term::ProgressBar->new(NAME2, 10); }, 
+                                                            'Count 1-10 ( 1)'),
+      1,                                                    'Count 1-10 ( 1)');
+  ok (evcheck(sub { $p->update($_) for 1..3  },             'Count 1-10 ( 2)'),
+      1,                                                    'Count 1-10 ( 2)');
+
+  my $err = restore_output('stderr');
+
+  $err =~ s!^.*\r!!gm;
+  print STDERR "ERR (1) :\n$err\nlength: ", length($err), "\n"
+    if $ENV{TEST_DEBUG};
+  my @lines = split /\n/, $err;
+  ok $lines[-1], qr/^@{[NAME2()]}: \s*\b30%/,                'Count 1-10 ( 3)';
+  my ($bar, $space) = $lines[-1] =~ /(\#*)(\s*)/;
+  my $length = length($bar) + length($space);
+  print STDERR
+    ("LENGTHS (1) :BAR:", length($bar), ":SPACE:", length($space), "\n")
+    if $ENV{TEST_DEBUG};
+  my $barexpect = $length * 0.3;
+  my $ok = length($bar) > $barexpect -1 && length($bar) < $barexpect+1;
+  ok $ok;
+
+  save_output('stderr', *STDERR{IO});
+
+  ok (evcheck(sub { $p->message(MESSAGE1)    },             'Count 1-10 ( 5)'),
+      1,                                                    'Count 1-10 ( 5)');
+  ok (evcheck(sub { $p->update($_) for 6..10 },             'Count 1-10 ( 6)'),
+      1,                                                    'Count 1-10 ( 6)');
+  $err = restore_output('stderr');
+
+  $err =~ s!^.*\r!!gm;
+  print STDERR "ERR (2) :\n$err\nlength: ", length($err), "\n"
+    if $ENV{TEST_DEBUG};
+
+  @lines = split /\n/, $err;
+
+  ok $lines[-1], qr/^@{[NAME2()]}: \s*\d+% \#*$/,            'Count 1-10 ( 8)';
+  ok $lines[-1], qr/^@{[NAME2()]}: \s*100%/,                 'Count 1-10 ( 9)';
+}
+
+# -------------------------------------
diff --git a/t/test.pm b/t/test.pm
new file mode 100644 (file)
index 0000000..59c25cb
--- /dev/null
+++ b/t/test.pm
@@ -0,0 +1,1188 @@
+# (X)Emacs mode: -*- cperl -*-
+
+package test;
+
+=head1 NAME
+
+test - tools for helping in test suites (not including running externalprograms).
+
+=head1 SYNOPSIS
+
+  use FindBin               1.42 qw( $Bin );
+  use Test                  1.13 qw( ok plan );
+
+  BEGIN { unshift @INC, $Bin };
+
+  use test                  qw( DATA_DIR
+                                evcheck runcheck );
+
+  BEGIN {
+    plan tests  => 3,
+         todo   => [],
+         ;
+  }
+
+  ok evcheck(sub {
+               open my $fh, '>', 'foo';
+               print $fh "$_\n"
+                 for 'Bulgaria', 'Cholet';
+               close $fh;
+             }, 'write foo'), 1, 'write foo';
+
+  save_output('stderr', *STDERR{IO});
+  warn 'Hello, Mum!';
+  print restore_output('stderr');
+
+=head1 DESCRIPTION
+
+This package provides some variables, and sets up an environment, for test
+scripts, such as those used in F<t/>.
+
+This package does not including running external programs; that is provided by
+C<test2.pm>.  This is so that suites not needing that can include only
+test.pm, and so not require the presence of C<IPC::Run>.
+
+Setting up the environment includes:
+
+=over 4
+
+=item Prepending F<blib/script> onto the path
+
+=item Pushing the module F<lib/> dir onto the @PERL5LIB var
+
+For executed scripts.
+
+=item Pushing the module F<lib/> dir onto the @INC var
+
+For internal C<use> calls.
+
+=item Changing directory to a temporary directory
+
+To avoid cluttering the local dir, and/or allowing the local directory
+structure to affect matters.
+
+=item Cleaning up the temporary directory afterwards
+
+Unless TEST_DEBUG is set in the environment.
+
+=back
+
+=cut
+
+# ----------------------------------------------------------------------------
+
+# Pragmas -----------------------------
+
+use 5.00503;
+use strict;
+use vars qw( @EXPORT_OK );
+
+# Inheritance -------------------------
+
+use base qw( Exporter );
+
+=head2 EXPORTS
+
+The following symbols are exported upon request:
+
+=over 4
+
+=item BIN_DIR
+
+=item DATA_DIR
+
+=item REF_DIR
+
+=item LIB_DIR
+
+=item PERL
+
+=item check_req
+
+=item compare
+
+=item evcheck
+
+=item only_files
+
+=item save_output
+
+=item restore_output
+
+=item tmpnam
+
+=item tempdir
+
+=item find_exec
+
+=item read_file
+
+=back
+
+=cut
+
+@EXPORT_OK = qw( BIN_DIR DATA_DIR REF_DIR LIB_DIR PERL
+                 check_req compare evcheck find_exec only_files read_file
+                 save_output restore_output tempdir tmpnam );
+
+# Utility -----------------------------
+
+use Carp                          qw( carp croak );
+use Cwd                      2.01 qw( cwd );
+use Env                           qw( PATH PERL5LIB );
+use Fatal                    1.02 qw( close open seek sysopen unlink );
+use Fcntl                    1.03 qw( :DEFAULT );
+use File::Basename                qw( basename );
+use File::Compare          1.1002 qw( );
+use File::Path             1.0401 qw( mkpath rmtree );
+use File::Spec                0.6 qw( );
+use FindBin                  1.42 qw( $Bin );
+use POSIX                    1.02 qw( );
+use Test                    1.122 qw( ok skip );
+
+# ----------------------------------------------------------------------------
+
+sub rel2abs {
+  if ( File::Spec->file_name_is_absolute($_[0]) ) {
+    return $_[0];
+  } else {
+    return catdir(cwd, $_[0]);
+  }
+}
+
+sub catdir {
+  File::Spec->catdir(@_);
+}
+
+sub catfile {
+  File::Spec->catfile(@_);
+}
+
+sub updir {
+  File::Spec->updir(@_);
+}
+
+sub min {
+  croak "Can't min over 0 args!\n"
+    unless @_;
+  my $min = $_[0];
+  for (@_[1..$#_]) {
+    $min = $_
+      if $_ < $min;
+  }
+
+  return $min;
+}
+
+sub max {
+  croak "Can't max over 0 args!\n"
+    unless @_;
+  my $max = $_[0];
+  for (@_[1..$#_]) {
+    $max = $_
+      if $_ > $max;
+  }
+
+  return $max;
+}
+
+# -------------------------------------
+# PACKAGE CONSTANTS
+# -------------------------------------
+
+use constant BIN_DIR  => catdir $Bin, updir, 'bin';
+use constant DATA_DIR => catdir $Bin, updir, 'data';
+use constant REF_DIR  => catdir $Bin, updir, 'testref';
+use constant LIB_DIR  => catdir $Bin, updir, 'lib';
+
+use constant BUILD_SCRIPT_DIR => => catdir $Bin, updir, qw( blib script );
+
+sub find_exec {
+  my ($exec) = @_;
+
+  for (split /:/, $PATH) {
+    my $try = catfile $_, $exec;
+    return rel2abs($try)
+      if -x $try;
+  }
+  return;
+}
+
+use constant PERL     => (basename($^X) eq $^X ? 
+                          find_exec($^X)       :
+                          rel2abs($^X));
+
+# -------------------------------------
+# PACKAGE ACTIONS
+# -------------------------------------
+
+# @PERL5LIB not available in Env for perl 5.00503
+# unshift @PERL5LIB, LIB_DIR;
+$PERL5LIB = defined $PERL5LIB ? join(':', LIB_DIR, $PERL5LIB) : LIB_DIR;
+unshift @INC,      LIB_DIR;
+
+$PATH = join ':', BUILD_SCRIPT_DIR, split /:/, $PATH;
+
+$_ = rel2abs($_)
+  for @INC;
+
+my $tmpdn = tempdir();
+$| = 1;
+
+mkpath $tmpdn;
+die "Couldn't create temp dir: $tmpdn: $!\n"
+  unless -r $tmpdn and -w $tmpdn and -x $tmpdn and -o $tmpdn and -d $tmpdn;
+
+#@INC = map rel2abs($_), @INC;
+chdir $tmpdn;
+
+# -------------------------------------
+# PACKAGE FUNCTIONS
+# -------------------------------------
+
+=head2 only_files
+
+=over 4
+
+=item ARGUMENTS
+
+=over 4
+
+=item expect
+
+Arrayref of names of files to expect to exist.
+
+=back
+
+=item RETURNS
+
+=over 4
+
+=item ok
+
+1 if exactly expected files exist, false otherwise.
+
+=back
+
+=back
+
+=cut
+
+sub only_files {
+  my ($expect) = @_;
+
+  local *MYDIR;
+  opendir MYDIR, '.';
+  my %files = map { $_ => 1 } readdir MYDIR;
+  closedir MYDIR;
+
+  my $ok = 1;
+
+  for (@$expect, '.', '..') {
+    if ( exists $files{$_} ) {
+      delete $files{$_};
+    } elsif ( ! -e $_ ) { # $_ might be absolute
+      carp "File not found: $_\n"
+        if $ENV{TEST_DEBUG};
+      $ok = 0;
+    }
+  }
+
+  for (keys %files) {
+    carp "Extra file found: $_\n"
+      if $ENV{TEST_DEBUG};
+    $ok = 0;
+  }
+
+  if ( $ok ) {
+    return 1;
+  } else {
+    return;
+  }
+}
+
+# -------------------------------------
+
+=head2 evcheck
+
+Eval code, return status
+
+=over 4
+
+=item ARGUMENTS
+
+=over 4
+
+=item code
+
+Coderef to eval
+
+=item name
+
+Name to use in error messages
+
+=back
+
+=item RETURNS
+
+=over 4
+
+=item okay
+
+1 if eval was okay, 0 if not.
+
+=back
+
+=back
+
+=cut
+
+sub evcheck {
+  my ($code, $name) = @_;
+
+  my $ok = 0;
+
+  eval {
+    &$code;
+    $ok = 1;
+  }; if ( $@ ) {
+    carp "Code $name failed: $@\n"
+      if $ENV{TEST_DEBUG};
+    $ok = 0;
+  }
+
+  return $ok;
+}
+
+# -------------------------------------
+
+=head2 save_output
+
+Redirect a filehandle to temporary storage for later examination.
+
+=over 4
+
+=item ARGUMENTS
+
+=over 4
+
+=item name
+
+Name to store as (used in L<restore_output>)
+
+=item filehandle
+
+The filehandle to save
+
+=back
+
+=cut
+
+# Map from names to saved filehandles.
+
+# Values are arrayrefs, being filehandle that was saved (to restore), the
+# filehandle being printed to in the meantime, and the original filehandle.
+# This may be treated as a stack; to allow multiple saves... push & pop this
+# stack.
+
+my %grabs;
+
+sub save_output {
+  croak sprintf("%s takes 2 arguments\n", (caller 0)[3])
+    unless @_ == 2;
+  my ($name, $filehandle) = @_;
+
+  my $tmpfh  = do { local *F; *F; };
+  my $savefh = do { local *F; *F; };
+
+  (undef, $tmpfh) = test::tmpnam();
+  select((select($tmpfh), $| = 1)[0]);
+
+  open $savefh, '>&' . fileno $filehandle
+    or die "can't dup $name: $!";
+  open $filehandle, '>&' . fileno $tmpfh
+    or die "can't open $name to tempfile: $!";
+
+  push @{$grabs{$name}}, $savefh, $tmpfh, $filehandle;
+}
+
+# -------------------------------------
+
+=head2 restore_output
+
+Restore a saved filehandle to its original state, return the saved output.
+
+=over 4
+
+=item ARGUMENTS
+
+=over 4
+
+=item name
+
+Name of the filehandle to restore (as passed to L<save_output>).
+
+=back
+
+=item RETURNS
+
+=over 4
+
+=item saved_string
+
+A single string being the output saved.
+
+=back
+
+=cut
+
+sub restore_output {
+  my ($name) = @_;
+
+  croak "$name has not been saved\n"
+    unless exists $grabs{$name};
+  croak "All saved instances of $name have been restored\n"
+    unless @{$grabs{$name}};
+  my ($savefh, $tmpfh, $origfh) = splice @{$grabs{$name}}, -3;
+
+  close $origfh
+    or die "cannot close $name opened to tempfile: $!";
+  open  $origfh, '>&' . fileno $savefh
+    or die "cannot dup $name back again: $!";
+  select((select($origfh), $| = 1)[0]);
+
+  seek $tmpfh, 0, 0;
+  local $/ = undef;
+  my $string = <$tmpfh>;
+  close $tmpfh;
+
+  return $string;
+}
+
+sub _test_save_restore_output {
+  warn "to stderr 1\n";
+  save_output("stderr", *STDERR{IO});
+  warn "Hello, Mum!";
+  print 'SAVED:->:', restore_output("stderr"), ":<-\n";
+  warn "to stderr 2\n";
+}
+
+# -------------------------------------
+
+=head2 tmpnam
+
+Very much like the one in L<POSIX> or L<File::Temp>, but does not get deleted
+if TEST_DEBUG has SAVE in the value.
+
+=over 4
+
+=item ARGUMENTS
+
+=over 4
+
+=item name
+
+I<Optional>.  If defined, a name by which to refer to the tmpfile in user
+messages.
+
+=back
+
+=item RETURNS
+
+=over 4
+
+=item filename
+
+Name of temporary file.
+
+=item fh
+
+Open filehandle to temp file, in r/w mode.  Only created & returned in list
+context.
+
+=back
+
+=back
+
+=cut
+
+my @tmpfns;
+
+BEGIN {
+  my $savewarn = $SIG{__WARN__};
+  # Subvert bizarre (& incorrect) subroutine redefined errors in 5.005_03
+  local $SIG{__WARN__} =
+    sub {
+      $savewarn->(@_)
+        if defined $savewarn                        and
+           UNIVERSAL::isa($savewarn,'CODE')         and
+           $_[0] !~ /^Subroutine tmpnam redefined/;
+    };
+
+  *tmpnam = sub {
+    my $tmpnam = POSIX::tmpnam;
+
+    if (@_) {
+      push @tmpfns, [ $tmpnam, $_[0] ];
+    } else {
+      push @tmpfns, $tmpnam;
+    }
+
+    if (wantarray) {
+      sysopen my $tmpfh, $tmpnam, O_RDWR | O_CREAT | O_EXCL;
+      return $tmpnam, $tmpfh;
+    } else {
+      return $tmpnam;
+    }
+  }
+}
+
+END {
+  if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) {
+    for (@tmpfns) {
+      if ( ref $_ ) {
+        printf "Used temp file: %s (%s)\n", @$_;
+      } else {
+        print "Used temp file: $_\n";
+      }
+    }
+  } else {
+    unlink map((ref $_ ? $_->[0] : $_), @tmpfns)
+      if @tmpfns;
+  }
+}
+
+# -------------------------------------
+
+=head2 tempdir
+
+Very much like the one in L<POSIX> or L<File::Temp>, but does not get deleted
+if TEST_DEBUG has SAVE in the value (does get deleted otherwise).
+
+=over 4
+
+=item ARGUMENTS
+
+I<None>
+
+=item RETURNS
+
+=over 4
+
+=item name
+
+Name of temporary dir.
+
+=back
+
+=back
+
+=cut
+
+my @tmpdirs;
+sub tempdir {
+  my $tempdir = POSIX::tmpnam;
+  mkdir $tempdir, 0700
+    or die "Failed to create temporary directory $tempdir: $!\n";
+
+  if (@_) {
+    push @tmpdirs, [ $tempdir, $_[0] ];
+  } else {
+    push @tmpdirs, $tempdir;
+  }
+
+  return $tempdir;
+}
+
+END {
+  for (@tmpdirs) {
+    if ( ref $_ ) {
+      if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) {
+        printf "Used temp dir: %s (%s)\n", @$_;
+      } else {
+        # Solaris gets narky about removing the pwd.
+        chdir File::Spec->rootdir;
+        rmtree $_->[0];
+      }
+    } else {
+      if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) {
+        print "Used temp dir: $_\n";
+      } else {
+        # Solaris gets narky about removing the pwd.
+        chdir File::Spec->rootdir;
+        rmtree $_;
+      }
+    }
+  }
+}
+
+# -------------------------------------
+
+=head2 compare
+
+  compare(+{ fn1 => $fn1, fn2 => $fn2, gzip => 1 });
+
+This performs one test.
+
+=over 4
+
+=item ARGUMENTS
+
+A single argument is taken, considered as a hash ref, with the following keys:
+
+In TEST_DEBUG mode, if the files do not compare equal, outputs file info on
+STDERR.
+
+=over 4
+
+=item fn1
+
+B<Mandatory>  File to compare
+
+=item fn2
+
+B<Mandatory>  File to compare
+
+=item name
+
+B<Mandatory>  Test name
+
+=item sort
+
+B<Optional> sort files prior to comparison.  Requires the C<sort> command to
+be on C<$PATH> (else skips).
+
+=item gunzip
+
+B<Optional> gunzip files prior to comparison.  Requires the C<gzip> command to
+be on C<$PATH> (else skips).  gzip occurs prior to any sort.
+
+=item untar
+
+B<Optional> untar files prior to comparison.  Requires the C<tar> command to
+be on C<$PATH> (else skips).  any gzip occurs prior to any tar.  Tar files are
+considered equal if they each contain the same filenames & each file contained
+is equal.  If the sort flag is present, each file is sorted prior to comparison.
+
+=back
+
+=back
+
+=cut
+
+#XYZ sub _run {
+#XYZ   my ($cmd, $name, $in) = @_;
+#XYZ
+#XYZ   my $infn = defined $in ? tmpnam : '/dev/null';
+#XYZ   my $outfn = tmpnam;
+#XYZ   my $errfn = tmpnam;
+#XYZ
+#XYZ   my $pid = fork;
+#XYZ   croak "Couldn't fork: $!\n"
+#XYZ     unless defined $pid;
+#XYZ
+#XYZ   if ( $pid == 0 ) { # Child
+#XYZ     open STDOUT, '>', $outfn;
+#XYZ     open STDERR, '>', $errfn;
+#XYZ     open STDIN,  '<', $infn;
+#XYZ
+#XYZ     exec @$cmd;
+#XYZ   }
+#XYZ
+#XYZ   my $rv = waitpid $pid, 0;
+#XYZ   my $status = $?;
+#XYZ
+#XYZ   croak "Unexpected waitpid return from child $name: $rv (expected $pid)\n"
+#XYZ     unless $rv == $pid;
+#XYZ
+#XYZ   local $/ = undef;
+#XYZ   local (OUT, ERR);
+#XYZ   open *OUT, '<', $outfn;
+#XYZ   open *ERR, '<', $errfn;
+#XYZ   my $out = <OUT>;
+#XYZ   my $err = <ERR>;
+#XYZ   close *OUT;
+#XYZ   close *ERR;
+#XYZ
+#XYZ   return $status >> 8, $status & 127, $status & 128 , $out, $err
+#XYZ }
+
+# return codes and old-style call semantics left for backwards compatibility
+BEGIN {
+  my $savewarn = $SIG{__WARN__};
+  # Subvert bizarre (& incorrect) subroutine redefined errors in 5.005_03
+  local $SIG{__WARN__} =
+    sub {
+      $savewarn->(@_)
+        if defined $savewarn                        and
+           UNIVERSAL::isa($savewarn,'CODE')         and
+           $_[0] !~ /^Subroutine compare redefined/;
+    };
+
+  *compare = sub {
+    my ($fn1, $fn2, $sort) = @_;
+    my ($gzip, $tar, $name);
+    my $notest = 1;
+
+    if ( @_ == 1 and UNIVERSAL::isa($_[0], 'HASH') ) {
+      ($fn1, $fn2, $name, $sort, $gzip, $tar, $notest) =
+        @{$_[0]}{qw( fn1 fn2 name sort gunzip untar notest )};
+      my @missing = grep ! defined $_[0]->{$_}, qw( fn1 fn2 name );
+      carp "Missing mandatory key(s): " . join(', ', @missing) . "\n"
+        if @missing;
+    }
+
+    my ($name1, $name2) = ($fn1, $fn2);
+
+    for ( grep ! defined, $fn1, $fn2 ) {
+      carp 'Usage: compare({fn1 => $fn1, fn2 => $fn2, name => "some name"})' ."\n"
+          if $ENV{TEST_DEBUG};
+      ok 0, 1, $name
+        unless $notest;
+      return -8;
+    }
+
+    {
+      my $err = 0;
+
+      for (0..1) {
+        my $fn = ($name1, $name2)[$_];
+        if ( ! -e $fn ) {
+          carp "Does not exist: $fn\n"
+            if $ENV{TEST_DEBUG};
+          $err |= 2 ** $_;
+        } elsif ( ! -r $fn ) {
+          carp "Cannot read: $fn\n"
+            if $ENV{TEST_DEBUG};
+          $err |= 2 ** $_;
+        }
+      }
+
+      if ( $err ) {
+        ok 0, 1, $name
+          unless $notest;
+        return -$err;
+      }
+    }
+
+    if ( $gzip ) {
+      unless ( find_exec('gzip') ) {
+        print "ok # Skip gzip not found in path\n";
+        return -16;
+      }
+
+      my $tmp1 = tmpnam;
+      my $tmp2 = tmpnam;
+      system "gzip $fn1 -cd > $tmp1"
+        and croak "gzip $fn1 failed: $?\n";
+      system "gzip $fn2 -cd > $tmp2"
+        and croak "gzip $fn2 failed: $?\n";
+      ($fn1, $fn2) = ($tmp1, $tmp2);
+    }
+
+    if ( $tar ) {
+      unless ( find_exec('tar') ) {
+        print "ok # Skip tar not found in path\n";
+        return -16;
+      }
+
+      local $/ = "\n";
+      chomp (my @list1 = sort qx( tar tf $fn1 ));
+      croak "tar tf $fn1 failed with wait status: $?\n"
+        if $?;
+      chomp(my @list2 = sort qx( tar tf $fn2 ));
+      croak "tar tf $fn2 failed with wait status: $?\n"
+        if $?;
+
+      if ( @list2 > @list1 ) {
+        carp
+          sprintf("More files (%d) in $name2 than $name1 (%d)\n",
+                  scalar @list2, scalar @list1)
+          if $ENV{TEST_DEBUG};
+        ok @list1, @list2, $name
+          unless $notest;
+        return 0;
+      } elsif ( @list1 > @list2 ) {
+        carp
+          sprintf("More files (%d) in $name1 than $name2 (%d)\n",
+                  scalar @list1, scalar @list2)
+          if $ENV{TEST_DEBUG};
+        ok @list1, @list2, $name
+          unless $notest;
+        return 0;
+      }
+
+      for (my $i = 0; $i < @list1; $i++) {
+        if ( $list1[$i] lt $list2[$i] ) {
+          carp "File $list1[$i] is present in $name1 but not $name2\n"
+            if $ENV{TEST_DEBUG};
+          ok $list1[$i], $list2[$i], $name
+            unless $notest;
+          return 0;
+        } elsif ( $list1[$i] gt $list2[$i] ) {
+          carp "File $list2[$i] is present in $name2 but not $name1\n"
+            if $ENV{TEST_DEBUG};
+          ok $list2[$i], $list1[$i], $name
+            unless $notest;
+          return 0;
+        }
+      }
+
+      for my $fn (@list1) {
+        my $tmp1 = tmpnam;
+        my $tmp2 = tmpnam;
+        system "tar -xf $fn1 -O $fn > $tmp1"
+          and croak "tar -xf $fn1 -O $fn failed: $?\n";
+        system "tar -xf $fn2 -O $fn > $tmp2"
+          and croak "tar -xf $fn2 -O $fn failed: $?\n";
+        my $ok = compare({ fn1    => $tmp1,
+                           fn2    => $tmp2,
+                           sort   => $sort,
+                           notest => 1,
+                           name   =>
+                             qq'Subcheck file "$fn" for compare $name1, $name2',
+                         });
+        unless ( $ok >= 1 ) {
+          carp qq'Difference found testing file "$fn" in tars $name1 ($tmp1), $name2 ($tmp2)\n'
+            if $ENV{TEST_DEBUG};
+          ok 0, 1, $name
+            unless $notest;
+          return 0;
+        }
+      }
+
+      ok 1, 1, $name
+        unless $notest;
+      return 1;
+    }
+
+    if ( $sort ) {
+      unless ( find_exec('sort') ) {
+        print "ok # Skip sort not found in path\n";
+        return -16;
+      }
+
+      my $tmp1 = tmpnam;
+      my $tmp2 = tmpnam;
+      system sort => $fn1, -o => $tmp1
+        and croak "Sort $fn1 failed: $?\n";
+      system sort => $fn2, -o => $tmp2
+        and croak "Sort $fn2 failed: $?\n";
+      ($fn1, $fn2) = ($tmp1, $tmp2);
+    }
+
+    unless ( File::Compare::compare($fn1, $fn2) ) {
+      ok 1, 1, $name
+        unless $notest;
+      return 1;
+    }
+
+    if ( $ENV{TEST_DEBUG} ) {
+      my $pid = fork;
+      die "Fork failed: $!\n"
+        unless defined $pid;
+
+      if ( $pid ) { # Parent
+        my $waitpid = waitpid($pid, 0);
+        die "Waitpid got: $waitpid (expected $pid)\n"
+          unless $waitpid == $pid;
+      } else { # Child
+        open *STDOUT{IO}, ">&" . fileno STDERR;
+        # Uniquify file names
+        my @args = keys %{+{ map {;$_=>1} $name1, $name2, $fn1, $fn2 }};
+        exec qw(ls -l), @args;
+      }
+
+      my $fh1 = IO::File->new($fn1, O_RDONLY)
+        or die "Couldn't open $fn1: $!\n";
+      my $fh2 = IO::File->new($fn2, O_RDONLY)
+        or die "Couldn't open $fn2: $!\n";
+
+      local $/ = "\n";
+
+      my $found = 0;
+      while ( ! $found and my $line1 = <$fh1> ) {
+        my $line2 = <$fh2>;
+        if ( ! defined $line2 ) {
+          print STDERR "$fn2 ended at line: $.\n";
+          $found = 1;
+        } elsif ( $line2 ne $line1 ) {
+          my $maxlength = max(map length($_), $line1, $line2);
+          my $minlength = min(map length($_), $line1, $line2);
+
+          my @diffchars = grep(substr($line1, $_, 1) ne substr($line2, $_, 1),
+                               0..$minlength-1);
+          my $diff = ' ' x $minlength;
+          substr($diff, $_, 1) = '|'
+            for @diffchars;
+
+          my @extrachars, map((length($line1) > length($line2) ? '^' : 'v'),
+                              $minlength..$maxlength-1);
+
+          $diff = join '', $diff, @extrachars;
+
+          my $diff_count  = @diffchars;
+          my $extra_count = @extrachars;
+
+          print STDERR <<"END";
+Difference at line $. ($diff_count characters differ) (top line is $extra_count chars longer):
+$name1:
+-->$line1<--
+   $diff
+-->$line2<--
+$name2:
+Differing characters at positions @{[join ',',@diffchars]} (zero-based)
+END
+          $found = 1;
+        }
+      }
+
+      if ( ! $found ) {
+        my $line2 = <$fh2>;
+        if ( defined $line2 ) {
+          print STDERR "$name1 ended before line: $.\n";
+        } else {
+          print STDERR "Difference between $name1, $name2 not found!\n";
+        }
+      }
+
+      close $fh1;
+      close $fh2;
+    }
+
+    ok 0, 1, $name
+      unless $notest;
+    return 0;
+  }
+}
+
+# -------------------------------------
+
+=head2 check_req
+
+Perform a requisite check on a given executable.  This will skip if the
+required modules are not present.
+
+4+(n+m)*2 tests are performed, where n is the number of prerequisites
+expected, and m is the number of outputs expected.
+
+=over 4
+
+=item SYNOPSIS
+
+  check_req('ccu-touch',
+            ['/etc/passwd'],
+            [[REQ_FILE, '/etc/passwd']],
+            [[REQ_FILE, 'passwd.foo']],
+            'requisites 1');
+
+
+=item ARGUMENTS
+
+=over 4
+
+=item cmd_name
+
+The name of the command to run.  It is assumed that this command is in
+blib/script; hence it should be an executable in this package, and C<make>
+shuold have been run recently.
+
+=item args
+
+The arguments to pass to the cmd_name, as an arrayref.
+
+=item epres
+
+The expected prerequisites, as an arrayref, wherein every member is a
+two-element arrayref, the members being the requisite type, and the requisite
+value.
+
+=item eouts
+
+The expected outputs, in the same format as the L<epres|"epres">.
+
+=item testname
+
+The name to use in error messages.
+
+=back
+
+=back
+
+=cut
+
+sub check_req {
+  my ($cmd_name, $args, $epres, $eouts, $testname) = @_;
+
+  eval "use Pipeline::DataFlow 1.03 qw( :req_types );";
+  my $skip;
+  if ( $@ ) {
+    print STDERR "$@\n"
+      if $ENV{TEST_DEBUG};
+    $skip = 'Skipped: Pipeline::DataFlow 1.03 not found';
+  } else {
+    $skip = 0;
+  }
+
+  my $count = 1;
+  my $test = sub {
+    my ($code, $expect) = @_;
+    my $name = sprintf "%s (%2d)", $testname, $count++;
+    my $value = UNIVERSAL::isa($code, 'CODE') ? $code->($name) : $code;
+    skip $skip, $value, $expect, $name;
+  };
+
+  # Initialize nicely to cope when read_reqs fails
+  my ($pres, $outs) = ([], []);
+
+  $test->(sub {
+            evcheck(sub {
+                      ($pres, $outs) = Pipeline::DataFlow->read_reqs
+                        ([catfile($Bin, updir, 'blib', 'script', $cmd_name),
+                          @$args]);
+                    }, $_[0]),},
+          1);
+
+  $test->(scalar @$pres, scalar @$epres);
+
+  my (@epres, @pres);
+  @epres = sort { $a->[1] cmp $b->[1] } @$epres;
+  @pres =  sort { $a->[1] cmp $b->[1] } @$pres;
+
+  for (my $i = 0; $i < @epres; $i++) {
+    my ($type, $value) = @{$epres[$i]};
+    $test->($type,  @pres > $i ? $pres[$i]->[0] : undef);
+    $test->($value, @pres > $i ? $pres[$i]->[1] : undef);
+  }
+
+  $test->(scalar @$outs, scalar @$eouts);
+
+  my (@eouts, @outs);
+  @eouts = sort { $a->[1] cmp $b->[1] } @$eouts;
+  @outs =  sort { $a->[1] cmp $b->[1] } @$outs;
+
+  for (my $i = 0; $i < @eouts; $i++) {
+    my ($type, $value) = @{$eouts[$i]};
+    $test->($type,  @outs > $i ? $outs[$i]->[0] : undef);
+    $test->($value, @outs > $i ? $outs[$i]->[1] : undef);
+  }
+
+  $test->(only_files([]), 1);
+}
+
+# -------------------------------------
+
+=head2 find_exec
+
+=over 4
+
+=item ARGUMENTS
+
+=over 4
+
+=item proggie
+
+The name of the program
+
+=back
+
+=item RETURNS
+
+=over 4
+
+=item path
+
+The path to the first executable file with the given name on C<$PATH>.  Or
+nothing, if no such file exists.
+
+=back
+
+=back
+
+=cut
+
+# defined further up to use in constants
+
+# -------------------------------------
+
+=head2 read_file
+
+=over 4
+
+=item ARGUMENTS
+
+=over 4
+
+=item filename
+
+B<Mandatory>
+
+=item line-terminator
+
+B<Optional>.  Value of C<$/>.  Defaults to C<"\n">.
+
+=back
+
+=item RETURNS
+
+=over 4
+
+=item lines
+
+A list of lines in the file (lines determined by the value of
+line-terminator), as an arrayref.
+
+=back
+
+=back
+
+=cut
+
+sub read_file {
+  my ($fn, $term) = @_;
+
+  $term = "\n"
+    unless defined $term;
+
+  my $fh = do { local *F; *F };
+  sysopen $fh, $fn, O_RDONLY;
+  local $/ = $term;
+  my @lines = <$fh>;
+  close $fh;
+
+  return \@lines;
+}
+
+# ----------------------------------------------------------------------------
+
+=head1 EXAMPLES
+
+Z<>
+
+=head1 BUGS
+
+Z<>
+
+=head1 REPORTING BUGS
+
+Email the author.
+
+=head1 AUTHOR
+
+Martyn J. Pearce C<fluffy@cpan.org>
+
+=head1 COPYRIGHT
+
+Copyright (c) 2001, 2002, 2004 Martyn J. Pearce.  This program is free
+software; you can redistribute it and/or modify it under the same terms as
+Perl itself.
+
+=head1 SEE ALSO
+
+Z<>
+
+=cut
+
+1; # keep require happy.
+
+__END__
diff --git a/t/v1-message.t b/t/v1-message.t
new file mode 100644 (file)
index 0000000..a34917d
--- /dev/null
@@ -0,0 +1,80 @@
+# (X)Emacs mode: -*- cperl -*-
+
+use strict;
+
+=head1 Unit Test Package for Term::ProgressBar
+
+This package tests the basic functionality of Term::ProgressBar.
+
+=cut
+
+use Data::Dumper qw( Dumper );
+use FindBin      qw( $Bin );
+use Test         qw( ok plan );
+
+use lib $Bin;
+use test qw( DATA_DIR
+             evcheck restore_output save_output );
+
+use constant MESSAGE1 => 'Walking on the Milky Way';
+
+BEGIN {
+  # 1 for compilation test,
+  plan tests  => 8,
+       todo   => [],
+}
+
+=head2 Test 1: compilation
+
+This test confirms that the test script and the modules it calls compiled
+successfully.
+
+=cut
+
+use Term::ProgressBar;
+
+ok 1, 1, 'compilation';
+
+Term::ProgressBar->__force_term (50);
+
+# -------------------------------------
+
+=head2 Tests 2--8: Count 1-10
+
+Create a progress bar with 10 things, and a name 'bob'.
+Update it it from 1 to 10.
+
+(1) Check no exception thrown on creation
+(2) Check no exception thrown on update (1..5)
+(3) Check no exception thrown on message send
+(4) Check no exception thrown on update (6..10)
+(5) Check message output.
+(5) Check bar is complete
+(6) Check bar number is 100%
+
+=cut
+
+{
+  my $p;
+  save_output('stderr', *STDERR{IO});
+  ok (evcheck(sub { $p = Term::ProgressBar->new('bob', 10); },
+              'Count 1-10 (1)' ),
+      1, 'Count 1-10 (1)');
+  ok (evcheck(sub { $p->update($_) for 1..5  }, 'Count 1-10 (2)' ),
+      1, 'Count 1-10 (2)');
+  ok (evcheck(sub { $p->message(MESSAGE1)    }, 'Count 1-10 (3)' ),
+      1, 'Count 1-10 (3)');
+  ok (evcheck(sub { $p->update($_) for 6..10 }, 'Count 1-10 (4)' ),
+      1, 'Count 1-10 (4)');
+  my $err = restore_output('stderr');
+
+  $err =~ s!^.*\r!!gm;
+  print STDERR "ERR:\n$err\nlength: ", length($err), "\n"
+    if $ENV{TEST_DEBUG};
+
+  my @lines = split /\n/, $err;
+
+  ok $lines[0], MESSAGE1;
+  ok $lines[-1], qr/bob:\s+\d+% \#+/,            'Count 1-10 (6)';
+  ok $lines[-1], qr/^bob:\s+100%/,               'Count 1-10 (7)';
+}
diff --git a/t/v2-message.t b/t/v2-message.t
new file mode 100644 (file)
index 0000000..3563495
--- /dev/null
@@ -0,0 +1,109 @@
+# (X)Emacs mode: -*- cperl -*-
+
+use strict;
+
+=head1 Unit Test Package for Term::ProgressBar
+
+This package tests the basic functionality of Term::ProgressBar.
+
+=cut
+
+use Data::Dumper 2.101 qw( Dumper );
+use FindBin 1.42 qw( $Bin );
+use Test 1.122 qw( ok plan );
+
+use lib $Bin;
+use test qw( DATA_DIR
+             evcheck restore_output save_output );
+
+use constant MESSAGE1 => 'Walking on the Milky Way';
+
+BEGIN {
+  # 1 for compilation test,
+  plan tests  => 11,
+       todo   => [],
+}
+
+=head2 Test 1: compilation
+
+This test confirms that the test script and the modules it calls compiled
+successfully.
+
+=cut
+
+use Term::ProgressBar;
+
+ok 1, 1, 'compilation';
+
+Term::ProgressBar->__force_term (50);
+
+# -------------------------------------
+
+=head2 Tests 2--8: Count 1-10
+
+Create a progress bar with 10 things.
+Update it it from 1 to 10.  Output a message halfway through.
+
+(1) Check no exception thrown on creation
+(2) Check no exception thrown on update (1..5)
+(3) Check no exception thrown on message send
+(4) Check no exception thrown on update (6..10)
+(5) Check message was issued.
+(6) Check bar is complete
+(7) Check bar number is 100%
+
+=cut
+
+{
+  my $p;
+  save_output('stderr', *STDERR{IO});
+  ok (evcheck(sub { $p = Term::ProgressBar->new(10); }, 'Count 1-10 (1)' ),
+      1, 'Count 1-10 (1)');
+  ok (evcheck(sub { $p->update($_) for 1..5  }, 'Count 1-10 (2)' ),
+      1, 'Count 1-10 (2)');
+  ok (evcheck(sub { $p->message(MESSAGE1)    }, 'Count 1-10 (3)' ),
+      1, 'Count 1-10 (3)');
+  ok (evcheck(sub { $p->update($_) for 6..10 }, 'Count 1-10 (4)' ),
+      1, 'Count 1-10 (4)');
+  my $err = restore_output('stderr');
+
+  $err =~ s!^.*\r!!gm;
+  print STDERR "ERR:\n$err\nlength: ", length($err), "\n"
+    if $ENV{TEST_DEBUG};
+
+  my @lines = split /\n/, $err;
+
+  ok $lines[0], MESSAGE1;
+  ok $lines[-1], qr/\[=+\]/,            'Count 1-10 (5)';
+  ok $lines[-1], qr/^\s*100%/,          'Count 1-10 (6)';
+}
+
+# -------------------------------------
+
+=head2 Tests 9--11: Message Check
+
+Run a progress bar from 0 to 100, each time calling a message after an update.
+This is to check that message preserves the progress bar value correctly.
+
+( 1) Check no exception thrown on creation
+( 2) Check no exception thrown on update, message (0..100).
+( 3) Check last progress is 100%
+
+=cut
+
+{
+  my $p;
+  save_output('stderr', *STDERR{IO});
+  ok (evcheck(sub { $p = Term::ProgressBar->new(100); }, 'Message Check ( 1)'),
+      1,                                                 'Message Check ( 1)');
+  ok (evcheck(sub { for (0..100) { $p->update($_); $p->message("Hello") } },
+              'Message Check ( 2)',), 
+      1,                                                 'Message Check ( 2)');
+  my $err = restore_output('stderr');
+
+  my @err_lines = split /\n/, $err;
+  (my $last_line = $err_lines[-1]) =~ tr/\r//d;
+  ok substr($last_line, 0, 4), '100%',               'Message Check ( 3)';
+}
+
+# ----------------------------------------------------------------------------
diff --git a/t/v2-mobile.t b/t/v2-mobile.t
new file mode 100644 (file)
index 0000000..c851278
--- /dev/null
@@ -0,0 +1,77 @@
+# (X)Emacs mode: -*- cperl -*-
+
+use strict;
+
+=head1 Unit Test Package for Term::ProgressBar
+
+This package tests the moving target functionality of Term::ProgressBar.
+
+=cut
+
+use Data::Dumper qw( Dumper );
+use FindBin      qw( $Bin );
+use Test         qw( ok plan );
+
+use lib $Bin;
+use test qw( DATA_DIR
+             evcheck restore_output save_output );
+
+BEGIN {
+  # 1 for compilation test,
+  plan tests  => 7,
+       todo   => [],
+}
+
+=head2 Test 1: compilation
+
+This test confirms that the test script and the modules it calls compiled
+successfully.
+
+=cut
+
+use Term::ProgressBar;
+
+ok 1, 1, 'compilation';
+
+Term::ProgressBar->__force_term (50);
+
+# -------------------------------------
+
+=head2 Tests 2--7: Count 1-20
+
+Create a progress bar with 10 things.
+Update it it from 1 to 5.
+Change target to 20.
+Update it from 11 to 20.
+
+(1) Check no exception thrown on creation
+(2) Check no exception thrown on update (1..5)
+(3) Check no exception thrown on target update
+(4) Check no exception thrown on update (6..10)
+(5) Check bar is complete
+(6) Check bar number is 100%
+
+=cut
+
+{
+  my $p;
+  save_output('stderr', *STDERR{IO});
+  ok (evcheck(sub { $p = Term::ProgressBar->new(10); }, 'Count 1-20 (1)' ),
+      1, 'Count 1-20 (1)');
+  ok (evcheck(sub { $p->update($_) for 1..5  },  'Count 1-20 (2)' ),
+      1, 'Count 1-20 (2)');
+  ok (evcheck(sub { $p->target(20)    },         'Count 1-20 (3)' ),
+      1, 'Count 1-20 (3)');
+  ok (evcheck(sub { $p->update($_) for 11..20 }, 'Count 1-20 (4)' ),
+      1, 'Count 1-20 (4)');
+  my $err = restore_output('stderr');
+
+  $err =~ s!^.*\r!!gm;
+  print STDERR "ERR:\n$err\nlength: ", length($err), "\n"
+    if $ENV{TEST_DEBUG};
+
+  my @lines = split /\n/, $err;
+
+  ok $lines[-1], qr/\[=+\]/,            'Count 1-20 (5)';
+  ok $lines[-1], qr/^\s*100%/,          'Count 1-20 (6)';
+}
diff --git a/t/v2-simple.t b/t/v2-simple.t
new file mode 100644 (file)
index 0000000..83015fd
--- /dev/null
@@ -0,0 +1,120 @@
+# (X)Emacs mode: -*- cperl -*-
+
+use strict;
+
+=head1 Unit Test Package for Term::ProgressBar
+
+This package tests the basic functionality of Term::ProgressBar.
+
+=cut
+
+use Data::Dumper qw( Dumper );
+use FindBin      qw( $Bin );
+use Test         qw( ok plan );
+
+use lib $Bin;
+use test qw( DATA_DIR
+             evcheck restore_output save_output );
+
+BEGIN {
+  # 1 for compilation test,
+  plan tests  => 31,
+       todo   => [],
+}
+
+=head2 Test 1: compilation
+
+This test confirms that the test script and the modules it calls compiled
+successfully.
+
+=cut
+
+use Term::ProgressBar;
+
+ok 1, 1, 'compilation';
+
+Term::ProgressBar->__force_term (50);
+
+# -------------------------------------
+
+=head2 Tests 2--16: Count 1-10
+
+Create a progress bar with 10 things.
+Update it it from 1 to 10.
+
+(1) Check no exception thrown on creation
+(2) Check no exception thrown on update
+(3) Check bar is complete
+(4) Check bar number is 100%
+(5--15) Check bar has no minor characters at any point
+
+=cut
+
+{
+  my $p;
+  save_output('stderr', *STDERR{IO});
+  ok (evcheck(sub { $p = Term::ProgressBar->new(10); }, 'Count 1-10 (1)' ),
+      1, 'Count 1-10 (1)');
+  ok (evcheck(sub { $p->update($_) for 1..10 }, 'Count 1-10 (2)' ),
+      1, 'Count 1-10 (2)');
+  my $err = restore_output('stderr');
+  my @lines = grep $_ ne '', split /\r/, $err;
+  print Dumper \@lines
+    if $ENV{TEST_DEBUG};
+  ok $lines[-1], qr/\[=+\]/,            'Count 1-10 (3)';
+  ok $lines[-1], qr/^\s*100%/,          'Count 1-10 (4)';
+  ok $lines[$_], qr/\[[= ]+\]/, sprintf('Count 1-10 (%d)', 5+$_)
+    for 0..10;
+}
+
+# -------------------------------------
+
+=head2 Tests 17--30: Count 1-9
+
+Create a progress bar with 10 things.
+Update it it from 1 to 9.
+
+(1) Check no exception thrown on creation
+(2) Check no exception thrown on update
+(3) Check bar is incomplete
+(4) Check bar number is 90%
+(5--14) Check bar has no minor characters at any point
+
+=cut
+
+{
+  my $p;
+  save_output('stderr', *STDERR{IO});
+  ok (evcheck(sub { $p = Term::ProgressBar->new(10); }, 'Count 1-9 (1)' ),
+      1, 'Count 1-9 (1)');
+  ok (evcheck(sub { $p->update($_) for 1..9 }, 'Count 1-9 (2)' ),
+      1, 'Count 1-9 (2)');
+  my $err = restore_output('stderr');
+  my @lines = grep $_ ne '', split /\r/, $err;
+  print Dumper \@lines
+    if $ENV{TEST_DEBUG};
+  ok $lines[-1], qr/\[=+ +\]/,          'Count 1-9 (3)';
+  ok $lines[-1], qr/^\s*90%/,           'Count 1-9 (4)';
+  ok $lines[$_], qr/\[[= ]+\]/, sprintf('Count 1-9 (%d)', 5+$_)
+    for 0..9;
+}
+
+# -------------------------------------
+
+=head2 Test 31
+
+Make sure the same progress bar text is not printed twice to the
+terminal (in the case of an update that is too little to affect the
+percentage or displayed bar).
+
+=cut
+{
+  save_output('stderr', *STDERR{IO});
+  my $b = Term::ProgressBar->new(1000000);
+  $b->update($_) foreach (0, 1);
+  my $err = restore_output('stderr');
+  my @lines = grep $_ ne '', split /\r/, $err;
+  print Dumper \@lines
+    if $ENV{TEST_DEBUG};
+  ok scalar @lines, 1;
+}
diff --git a/t/zero.t b/t/zero.t
new file mode 100644 (file)
index 0000000..737f508
--- /dev/null
+++ b/t/zero.t
@@ -0,0 +1,101 @@
+# (X)Emacs mode: -*- cperl -*-
+
+use strict;
+
+=head1 Unit Test Package for Term::ProgressBar
+
+This package tests the zero-progress handling of progress bar.
+
+=cut
+
+use Data::Dumper qw( Dumper );
+use FindBin      qw( $Bin );
+use Test         qw( ok plan );
+
+use lib $Bin;
+use test qw( DATA_DIR
+             evcheck restore_output save_output );
+
+BEGIN {
+  # 1 for compilation test,
+  plan tests  => 9,
+       todo   => [],
+}
+
+=head2 Test 1: compilation
+
+This test confirms that the test script and the modules it calls compiled
+successfully.
+
+=cut
+
+use Term::ProgressBar;
+
+ok 1, 1, 'compilation';
+
+Term::ProgressBar->__force_term (50);
+
+# -------------------------------------
+
+=head2 Tests 2--5: V1 mode
+
+Create a progress bar with 0 things.
+Update it it from 1 to 10.
+
+(1) Check no exception thrown on creation
+(2) Check no exception thrown on update
+(3) Check bar displays name
+(3) Check bar says nothing to do
+
+=cut
+
+{
+  my $p;
+  save_output('stderr', *STDERR{IO});
+  my $name = 'doing nothing';
+  ok (evcheck(sub { $p = Term::ProgressBar->new($name, 0); },
+        'V1 mode ( 1)' ),
+      1,                                                       'V1 mode ( 1)');
+  ok (evcheck(sub { $p->update($_) for 1..10 },'V1 mode ( 2)'),
+      1,                                                       'V1 mode ( 2)');
+  my $err = restore_output('stderr');
+  my @lines = grep $_ ne '', split /\r/, $err;
+  print Dumper \@lines
+    if $ENV{TEST_DEBUG};
+  ok $lines[-1], qr/^$name:/,                                  'V1 mode ( 3)';
+  ok $lines[-1], qr/\(nothing to do\)/,                        'V1 mode ( 4)';
+}
+
+# -------------------------------------
+
+=head2 Tests 6--9: V2 mode
+
+Create a progress bar with 0 things.
+Update it it from 1 to 10.
+
+(1) Check no exception thrown on creation
+(2) Check no exception thrown on update
+(3) Check bar displays name
+(4) Check bar says nothing to do
+
+=cut
+
+{
+  my $p;
+  save_output('stderr', *STDERR{IO});
+  my $name = 'zero';
+  ok (evcheck(sub { $p = Term::ProgressBar->new({ count => 0,
+                                                  name => $name }); },
+        'V2 mode ( 1)' ),
+      1,                                                       'V2 mode ( 1)');
+  ok (evcheck(sub { $p->update($_) for 1..10 },'V2 mode ( 2)'),
+      1,                                                       'V2 mode ( 2)');
+  my $err = restore_output('stderr');
+  my @lines = grep $_ ne '', split /\r/, $err;
+  print Dumper \@lines
+    if $ENV{TEST_DEBUG};
+  ok $lines[-1], qr/^$name:/,                                  'V2 mode ( 3)';
+  ok $lines[-1], qr/\(nothing to do\)/,                        'V2 mode ( 4)';
+}
+
+# ----------------------------------------------------------------------------