--- /dev/null
+001 1.50 Wrong minor character (= should be *) selected by default.
+ 1.51 Fixed
\ No newline at end of file
--- /dev/null
+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
--- /dev/null
+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>
--- /dev/null
+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.
--- /dev/null
+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
--- /dev/null
+^(.*/)?CVS/.*
+^Makefile(.old)?$
+^Build$
+^Clean$
+^RollingBuild$
+^blib/.*
+^pm_to_blib$
+^(.*/)?.cvsignore$
+^MANIFEST.bak$
+^*~$
+^make[-.]pm$
+^INFO.yaml$
+^_build/
--- /dev/null
+--- #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
--- /dev/null
+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 )) },
+);
--- /dev/null
+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
--- /dev/null
+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-----
--- /dev/null
+#!/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';
--- /dev/null
+#!/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($_);
+ }
+}
--- /dev/null
+#!/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($_);
+}
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+#!/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;
--- /dev/null
+# (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__
--- /dev/null
+# (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__
--- /dev/null
+#!/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";
+}
+
--- /dev/null
+# (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";
--- /dev/null
+# (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)';
+}
+
+# ----------------------------------------------------------------------------
--- /dev/null
+# (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)';
+}
+
+# -------------------------------------
--- /dev/null
+# (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__
--- /dev/null
+# (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)';
+}
--- /dev/null
+# (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)';
+}
+
+# ----------------------------------------------------------------------------
--- /dev/null
+# (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)';
+}
--- /dev/null
+# (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;
+}
--- /dev/null
+# (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)';
+}
+
+# ----------------------------------------------------------------------------
projects / term-progressbar.git / commitdiff