From 3797cda1b0da9caa24c7ff35e910e1f318c77918 Mon Sep 17 00:00:00 2001 From: Gabor Szabo Date: Tue, 29 Nov 2011 15:06:38 +0200 Subject: [PATCH 1/1] import Term-ProgressBar-2.09 from CPAN --- BUGS | 2 + Build.PL | 15 + Changes | 63 +++ INSTALL | 21 + MANIFEST | 28 + MANIFEST.SKIP | 13 + META.yml | 16 + Makefile.PL | 24 + README | 38 ++ SIGNATURE | 50 ++ configure | 46 ++ examples/powers | 20 + examples/powers2 | 18 + examples/powers3 | 23 + examples/powers4 | 26 + examples/powers5 | 26 + lib/Term/ProgressBar.pm | 959 +++++++++++++++++++++++++++++++ make-pm | 538 ++++++++++++++++++ t/0-signature.t | 16 + t/compat.t | 136 +++++ t/eta-linear.t | 86 +++ t/name.t | 169 ++++++ t/test.pm | 1188 +++++++++++++++++++++++++++++++++++++++ t/v1-message.t | 80 +++ t/v2-message.t | 109 ++++ t/v2-mobile.t | 77 +++ t/v2-simple.t | 120 ++++ t/zero.t | 101 ++++ 28 files changed, 4008 insertions(+) create mode 100644 BUGS create mode 100644 Build.PL create mode 100644 Changes create mode 100644 INSTALL create mode 100644 MANIFEST create mode 100644 MANIFEST.SKIP create mode 100644 META.yml create mode 100644 Makefile.PL create mode 100644 README create mode 100644 SIGNATURE create mode 100644 configure create mode 100644 examples/powers create mode 100644 examples/powers2 create mode 100644 examples/powers3 create mode 100644 examples/powers4 create mode 100644 examples/powers5 create mode 100644 lib/Term/ProgressBar.pm create mode 100644 make-pm create mode 100644 t/0-signature.t create mode 100644 t/compat.t create mode 100644 t/eta-linear.t create mode 100644 t/name.t create mode 100644 t/test.pm create mode 100644 t/v1-message.t create mode 100644 t/v2-message.t create mode 100644 t/v2-mobile.t create mode 100644 t/v2-simple.t create mode 100644 t/zero.t diff --git a/BUGS b/BUGS new file mode 100644 index 0000000..dfcda10 --- /dev/null +++ b/BUGS @@ -0,0 +1,2 @@ +001 1.50 Wrong minor character (= should be *) selected by default. + 1.51 Fixed \ No newline at end of file diff --git a/Build.PL b/Build.PL new file mode 100644 index 0000000..5fd8f84 --- /dev/null +++ b/Build.PL @@ -0,0 +1,15 @@ +use Module::Build 0.18; + +use File::Spec; + +my $build = Module::Build->new + (module_name => 'Term::ProgressBar', + dist_version => '2.09', + license => 'perl', + requires => { + Class::MethodMaker => '1.02', + Term::ReadKey => '2.14', + }, + ); + +$build->create_build_script diff --git a/Changes b/Changes new file mode 100644 index 0000000..122e0c5 --- /dev/null +++ b/Changes @@ -0,0 +1,63 @@ +Revision history for Perl extension Term-ProgressBar. + +2.09 Sun Mar 13 9:17 PM GMT 2005 + - Fix for incorrect formatting of 'D...' time done at end + +2.08 Sat Mar 12 11:47 AM GMT 2005 + - Add remove option + - Add patch to account for weird terminal sizing under Windoze + (thanks to Andrew Peters for the patch). + +2.07 Sun Mar 6 1:31 PM GMT 2005 + - Correct handling of non-term mode to output stats but no PB + - Print time taken to complete in ETA mode when Done + - Add use of 'name' to example in 'new' doc + - Add doc of use of minor characters to description + - Add doc. for name value to new + +2.06 Sun Mar 14 10:46 AM GMT 2004 + - Add patch to cope when terminal size cannot be detected or is + too small. + Thanks to Ed Avis () 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 () for the patch. + - Add patch to suppress unnecessary terminal updates + Thanks to Ed Avis () 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 () 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, diff --git a/INSTALL b/INSTALL new file mode 100644 index 0000000..66d6aec --- /dev/null +++ b/INSTALL @@ -0,0 +1,21 @@ +To install this module, use + + ./configure + make + make test + make install + +This will install using /usr/bin/perl . If you wish to install using the perl +in your PATH, use 'perl ./configure' instead of 'configure'. + +If you wish to install to a non-standard location, use 'configure +--prefix=location' instead of 'configure'. + +So, to use the perl in your PATH to install to '/tmp', use + + perl ./configure --prefix=/tmp + make + make test + make install + +Enjoy. diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..8b8a54b --- /dev/null +++ b/MANIFEST @@ -0,0 +1,28 @@ +Changes +MANIFEST +MANIFEST.SKIP +README +lib/Term/ProgressBar.pm +t/compat.t +Makefile.PL +BUGS +t/test.pm +t/v2-message.t +t/v2-simple.t +t/v2-mobile.t +t/name.t +examples/powers +examples/powers2 +examples/powers3 +examples/powers4 +examples/powers5 +t/eta-linear.t +t/v1-message.t +t/zero.t +META.yml +t/0-signature.t +make-pm +configure +Build.PL +SIGNATURE +INSTALL diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP new file mode 100644 index 0000000..21cf8b6 --- /dev/null +++ b/MANIFEST.SKIP @@ -0,0 +1,13 @@ +^(.*/)?CVS/.* +^Makefile(.old)?$ +^Build$ +^Clean$ +^RollingBuild$ +^blib/.* +^pm_to_blib$ +^(.*/)?.cvsignore$ +^MANIFEST.bak$ +^*~$ +^make[-.]pm$ +^INFO.yaml$ +^_build/ diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..e767152 --- /dev/null +++ b/META.yml @@ -0,0 +1,16 @@ +--- #YAML:1.0 +name: Term-ProgressBar +version: 2.09 +license: perl +distribution_type: module +requires: + Class::MethodMaker: 1.02 + Term::ReadKey: 2.14 +recommends: {} +build_requires: {} +conflicts: {} +provides: + Term::ProgressBar: + file: lib/Term/ProgressBar.pm + version: 2.09 +generated_by: Module::Build version 0.21 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..d227a21 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,24 @@ +require 5.006; +use strict; + +use ExtUtils::MakeMaker; + +WriteMakefile ( + NAME => 'Term-ProgressBar', + VERSION => '2.09', + AUTHOR => 'Martyn J. Pearce ', + ABSTRACT => 'provide a progress meter on a standard terminal', + PREREQ_PM => +{ + 'Class::MethodMaker' => '1.02', + 'Term::ReadKey' => '2.14',}, + EXE_FILES => [qw( )], + # Need this to stop Makefile treating Build.PL as a producer of Build as a + # target for 'all'. + PL_FILES => +{}, + clean => +{ FILES => join(' ', qw( Build _build )) }, + realclean => +{ FILES => join(' ', qw( Build.PL META.yml + Makefile.PL + SIGNATURE + README INSTALL + configure make-pm )) }, +); diff --git a/README b/README new file mode 100644 index 0000000..a629fa2 --- /dev/null +++ b/README @@ -0,0 +1,38 @@ +Module Term-ProgressBar (2.09): + +Description: + + A progress bar for things that take a while. It looks like + + 50% [===== ] + + and is as long as the terminal. Linear estimation of the time left for + the process to run is available. + +Modules & Classes Provided: + + Term::ProgressBar - provide a progress meter on a standard terminal + +Required Packages: + + Class::MethodMaker 1.02 + Term::ReadKey 2.14 + +Required Perl Version: + + 5.006 + +Package Maintainer: + + Martyn J. Pearce fluffy@cpan.org + +Copyright: + + Copyright (c) 2005, 2004, 2003, 2002, 2001 Martyn J. Pearce. This + program is free software; you can redistribute it and/or modify it + under the same terms as Perl itself. + + Copyright (c) 2000 Ed Avis. This program is free software; you can + redistribute it and/or modify it under the same terms as Perl itself. + +13th March, 2005 diff --git a/SIGNATURE b/SIGNATURE new file mode 100644 index 0000000..7afe032 --- /dev/null +++ b/SIGNATURE @@ -0,0 +1,50 @@ +This file contains message digests of all files listed in MANIFEST, +signed via the Module::Signature module, version 0.38. + +To verify the content in this distribution, first make sure you have +Module::Signature installed, then type: + + % cpansign -v + +It would check each file's integrity, as well as the signature's +validity. If "==> Signature verified OK! <==" is not displayed, +the distribution may already have been compromised, and you should +not run its Makefile.PL or Build.PL. + +-----BEGIN PGP SIGNED MESSAGE----- +Hash: SHA1 + +SHA1 308e635e1928d03e6c92ef224557847e18f492a6 BUGS +SHA1 466429e1cefc8de46f7310bc7c64e6ac6af108e0 Build.PL +SHA1 2cb916a845f60e44d62efe689de063d7bef20a99 Changes +SHA1 efa8cb615886410be8de15f5a6925697f624d278 INSTALL +SHA1 d0e591b2e5eafcc9a8de8ff9eda691fad5f85ffc MANIFEST +SHA1 5c69f53a9cb6f5f717dd1d02266fc7c9f675a902 MANIFEST.SKIP +SHA1 45fa692c1ad1ec954fe181c2d77b674f478a4201 META.yml +SHA1 c88a83fd974fad3c16428163c87d3e6835296ae7 Makefile.PL +SHA1 0de078a628603bf24ba4d01f2eb004360661be68 README +SHA1 8f869f84e72c6fc7ac89ce26326bf981505be467 configure +SHA1 8a4e566bff0ad33481975d55bcef13a9244bde16 examples/powers +SHA1 cb478a1724ae1816e12511be593fd33517702413 examples/powers2 +SHA1 ff6df90436963b2b7e73f8ce6d6327f2dbcad1c3 examples/powers3 +SHA1 0fca941997cba7e66d39d4cec737ef09ee7df454 examples/powers4 +SHA1 37691f612074aa2fcea31c3b17c6ee46640f43db examples/powers5 +SHA1 cef7ba06dd315bf803d87ab7753ed7b92fb45818 lib/Term/ProgressBar.pm +SHA1 37ba03162a46931b496a18413401d8f25b303cf1 make-pm +SHA1 e7569e5eeef2a8558e6d4828be087a6e1a841295 t/0-signature.t +SHA1 433e3ecad2aa8a7b3bb2f3766b17c195b33cbcc5 t/compat.t +SHA1 f02bc46da7e3c83478c244adfad443f9c1a2b4ca t/eta-linear.t +SHA1 f3b178ae1e9f1f1789443522ac861c8421f93eee t/name.t +SHA1 037b2bf330c9ce722c1d122e4e561c610f4fee83 t/test.pm +SHA1 ab36b1695c7ca9281da620347487bf88d02e66da t/v1-message.t +SHA1 91f9f8f0765d5d7924c4c130934facb91eca6833 t/v2-message.t +SHA1 87ecb3158e5eb9fe020c819e2d2f80ff8be45d92 t/v2-mobile.t +SHA1 119b353912834b0040150a7094bf14425be03936 t/v2-simple.t +SHA1 9048c3d6b67959e3cd598ac0e151daff435f39fe t/zero.t +-----BEGIN PGP SIGNATURE----- +Version: GnuPG v1.2.2 (Darwin) + +iD8DBQFCNK9oV6eZRcV4WK0RAlXrAKDKPgq5cPXM5PnlAh6a08MK0nUNpACdGd20 +54twrpUeCdFMSQoExw0HNrQ= +=pBXe +-----END PGP SIGNATURE----- diff --git a/configure b/configure new file mode 100644 index 0000000..5ec7005 --- /dev/null +++ b/configure @@ -0,0 +1,46 @@ +#!/usr/bin/perl -w + +use 5.006; +use strict; + +use File::Spec qw( ); +use Getopt::Long 2.19 qw( GetOptions ); + +my $DEBUG; +my $prefix; +GetOptions ('debug' => \$DEBUG, + 'prefix=s' => \$prefix, + ) + or die "Options parsing failed"; + +warn "Building with perl: $^X\n"; + +use constant MOD_REQS => + [ + { name => 'Class::MethodMaker', + version => '1.02', + + }, + + { name => 'Term::ReadKey', + version => '2.14', + package => 'TermReadKey', + }, + + ]; + +use constant EXEC_REQS => [ ]; + + + +use constant NAME => 'Term-ProgressBar'; +use constant VERSION_FROM => + File::Spec->catfile(qw( lib Term ProgressBar.pm )); +use constant AUTHOR => 'Martyn J. Pearce '; +use constant ABSTRACT => 'provide a progress meter on a standard terminal'; +sub PREFIX { $prefix } + +use FindBin 1.42 qw( $Bin ); +use lib $Bin; +use lib '.'; +require 'make-pm'; diff --git a/examples/powers b/examples/powers new file mode 100644 index 0000000..351abe9 --- /dev/null +++ b/examples/powers @@ -0,0 +1,20 @@ +#!/usr/bin/perl + +use Term::ProgressBar 2.00; + +use constant MAX => 100_000; + +my $max = int($ARGV[0]+0) || MAX; +my $progress = Term::ProgressBar->new($max); + +for (0..$max) { + my $is_power = 0; + for(my $i = 0; 2**$i <= $_; $i++) { + $is_power = 1 + if 2**$i == $_; + } + + if ( $is_power ) { + $progress->update($_); + } +} diff --git a/examples/powers2 b/examples/powers2 new file mode 100644 index 0000000..23147a0 --- /dev/null +++ b/examples/powers2 @@ -0,0 +1,18 @@ +#!/usr/bin/perl + +use Term::ProgressBar 2.00; + +use constant MAX => 100_000; + +my $max = int($ARGV[0]+0) || MAX; +my $progress = Term::ProgressBar->new($max); + +for (0..$max) { + my $is_power = 0; + for(my $i = 0; 2**$i <= $_; $i++) { + $is_power = 1 + if 2**$i == $_; + } + + $progress->update($_); +} diff --git a/examples/powers3 b/examples/powers3 new file mode 100644 index 0000000..82ae224 --- /dev/null +++ b/examples/powers3 @@ -0,0 +1,23 @@ +#!/usr/bin/perl + +use Term::ProgressBar 2.00; + +use constant MAX => 100_000; + +my $max = int($ARGV[0]+0) || MAX; +my $progress = Term::ProgressBar->new({name => 'Powers', count => $max, remove => 3}); +$progress->minor(0); +my $next_update = 0; + +for (0..$max) { + my $is_power = 0; + for(my $i = 0; 2**$i <= $_; $i++) { + $is_power = 1 + if 2**$i == $_; + } + + $next_update = $progress->update($_) + if $_ > $next_update; +} +$progress->update($max) + if $max >= $next_update; diff --git a/examples/powers4 b/examples/powers4 new file mode 100644 index 0000000..ad9353e --- /dev/null +++ b/examples/powers4 @@ -0,0 +1,26 @@ +#!/usr/bin/perl + +use Term::ProgressBar 2.00; + +use constant MAX => 1_000_000; + +my $max = int($ARGV[0]+0) || MAX; +my $progress = Term::ProgressBar->new({name => 'Powers', count => $max, + ETA => linear, }); +#$progress->minor(0); +my $next_update = 0; + +for (0..$max) { + my $is_power = 0; + for(my $i = 0; 2**$i <= $_; $i++) { + $is_power = 1 + if 2**$i == $_; + } +sleep 1 +if $_ % 4 == 0; + + $next_update = $progress->update($_) + if $_ > $next_update; +} +$progress->update($max) + if $max >= $next_update; diff --git a/examples/powers5 b/examples/powers5 new file mode 100644 index 0000000..bc0c310 --- /dev/null +++ b/examples/powers5 @@ -0,0 +1,26 @@ +#!/usr/bin/perl + +use Term::ProgressBar 2.00; + +use constant MAX => 10_000_000; + +my $max = int($ARGV[0]+0) || MAX; +my $progress = Term::ProgressBar->new({name => 'Powers', count => $max, + ETA => linear, }); +$progress->max_update_rate(1); +my $next_update = 0; + +for (0..$max) { + my $is_power = 0; + for(my $i = 0; 2**$i <= $_; $i++) { + if ( 2**$i == $_ ) { + $is_power = 1; + $progress->message(sprintf "Found %8d to be 2 ** %2d", $_, $i); + } + } + + $next_update = $progress->update($_) + if $_ > $next_update; +} +$progress->update($max) + if $max >= $next_update; diff --git a/lib/Term/ProgressBar.pm b/lib/Term/ProgressBar.pm new file mode 100644 index 0000000..f1ed1dc --- /dev/null +++ b/lib/Term/ProgressBar.pm @@ -0,0 +1,959 @@ +# (X)Emacs mode: -*- cperl -*- + +package Term::ProgressBar; + +#XXX TODO Redo original test with count=20 +# Amount Output +# Amount Prefix/Suffix +# Tinker with $0? +# Test use of last_update (with update(*undef*)) with scales +# Choice of FH other than STDERR +# If no term, output no progress bar; just progress so far +# Use of simple term with v2.0 bar +# If name is wider than term, trim name +# Don't update progress bar on new? + +=head1 NAME + +Term::ProgressBar - provide a progress meter on a standard terminal + +=head1 SYNOPSIS + + use Term::ProgressBar; + + $progress = Term::ProgressBar->new ({count => $count}); + $progress->update ($so_far); + +=head1 DESCRIPTION + +Term::ProgressBar provides a simple progress bar on the terminal, to let the +user know that something is happening, roughly how much stuff has been done, +and maybe an estimate at how long remains. + +A typical use sets up the progress bar with a number of items to do, and then +calls L 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 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 character: +this is a character that I 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 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 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 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 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 +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 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 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 call. See the +documentation for the L method for details of the format(s) used. + +This example also provides an example of the use of the L +function to output messages to the same filehandle whilst keeping the progress bar intact + +The complete text of this example is in F 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 key. + +=over 4 + +=item count + +The item count. The progress is marked at 100% when update I 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; 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 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 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 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 defaults to 0.5, being the +number of seconds between updates. + +=back + +=head2 Boolean Components + +See L 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. + +See F and F 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). +# 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. + +If not defined, assumed to be 1+ whatever was the value last time C +was called (starting at 0). + +=back + +=item RETURNS + +=over 4 + +=item next_call + +The next value of so_far at which to call C. + +=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 operates in v1 +compatibility mode: the arguments are considered to be name, and item count. +Various other defaults are set to emulate version one (e.g., the major output +character is '#', the bar width is set to 50 characters and the output +filehandle is not treated as a terminal). This mode is deprecated. + +=head1 AUTHOR + +Martyn J. Pearce fluffy@cpan.org + +Significant contributions from Ed Avis, amongst others. + +=head1 COPYRIGHT + +Copyright (c) 2001, 2002, 2003, 2004, 2005 Martyn J. Pearce. This program is +free software; you can redistribute it and/or modify it under the same terms +as Perl itself. + +=head1 SEE ALSO + +Z<> + +=cut + +1; # keep require happy. + +__END__ diff --git a/make-pm b/make-pm new file mode 100644 index 0000000..b84051a --- /dev/null +++ b/make-pm @@ -0,0 +1,538 @@ +# (X)Emacs mode: -*- cperl -*- + +use 5.005; +use strict; + +=head1 NAME + +make - tools for making makefiles with. + +=head1 SYNOPSIS + + use constant MOD_REQS => + [ + { name => 'Pod::Usage', + version => '1.12', }, + + { name => 'IPC::Run', + package => 'IPC-Run', + version => '0.44', }, + + { name => 'DBI::Wrap', + package => 'DBI-Wrap', + version => '1.00', + optional => 1, }, + ]; + + use constant EXEC_REQS => + [ + { name => 'blastpgp', + version => '1.50', + vopt => '--version', }, + + { name => 'mkprofile', }, + + { name => 'mp3id', + version => '0.4', + vopt => '--help', + vexpect => 255, }, + ]; + + use constant NAME => 'Module-Name'; + use constant VERSION_FROM => catfile (qw( lib Module Name.pm )); + use constant AUTHOR => 'Martyn J. Pearce fluffy@cpan.org'; + use constant ABSTRACT => 'This module makes chocolate biscuits'; + + use make.pm + +=head1 DESCRIPTION + +This package provides methods and initialization to build standard perl +modules. + +The plan is, you define the requirements, and let the module take care of the +rest. + +The requirements you must define are: + +=over 4 + +=item MOD_REQS + +An arrayref of hashrefs. Each hashref represents a required Perl module, and +has the following keys: + +=over 4 + +=item name + +B 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 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 which have been added to +the core since 5.005. + +=item version + +B 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 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 Name of the package in which the executable is to be found. + +=item version + +B 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 key must also be supplied. + +=item vopt + +B This is used only if the C 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 is +defined). + +=item vexpect + +B This is used only if the C 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 the value of the C call. + +=item optional + +B 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 contain colon characters. The usual process, when providing a +single-package module (e.g., to provide C), is to replace the +C<::> occurences with hyphens (hence, C). + +=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) +are fine; C 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 + +If defined, this must be an arrayref of additional targets to insert into +F. 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. 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 finds the pms to install by a conducting a C over +the F directory when C 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 is issued. This might well be used in conjunction with the +L 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 { + < 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 + +=head1 COPYRIGHT + +Copyright (c) 2001, 2002, 2003 Martyn J. Pearce. This program is free +software; you can redistribute it and/or modify it under the same terms as +Perl itself. + +=head1 SEE ALSO + +Z<> + +=cut + +1; # keep require happy + +__END__ diff --git a/t/0-signature.t b/t/0-signature.t new file mode 100644 index 0000000..9de4488 --- /dev/null +++ b/t/0-signature.t @@ -0,0 +1,16 @@ +#!/usr/bin/perl +use strict; +print "1..1\n"; + +if ( ! eval { require Module::Signature; 1 } ) { + print("ok 1 # skip ", + "Next time around, consider install Module::Signature, ", + "# so you can verify the integrity of this distribution.\n"); +} elsif ( ! eval { require Socket; Socket::inet_aton('pgp.mit.edu') } ) { + print "ok 1 # skip ", "Cannot connect to the keyserver\n"; +} else { + (Module::Signature::verify() == Module::Signature::SIGNATURE_OK()) + or print "not "; + print "ok 1 # Valid signature\n"; +} + diff --git a/t/compat.t b/t/compat.t new file mode 100644 index 0000000..9aa8efc --- /dev/null +++ b/t/compat.t @@ -0,0 +1,136 @@ +# (X)Emacs mode: -*- cperl -*- + +use strict; + +=head1 Unit Test Package for Term::ProgressBar v1.0 Compatibility + +This script is based on the test script for Term::ProgressBar version 1.0, +and is intended to test compatibility with that version. + +=cut + +# Utility ----------------------------- + +use Data::Dumper qw( ); +use Test qw( ok plan ); + +# Test Setup -------------------------- + +BEGIN { + plan tests => 5, + todo => [], + ; +} + +# ------------------------------------- + +# grab_output() +# +# Eval some code and return what was printed to stdout and stderr. +# +# Parameters: string of code to eval +# +# Returns: listref of [ stdout text, stderr text ] +# +sub grab_output($) { + die 'usage: grab_stderr(string to eval)' if @_ != 1; + my $code = shift; + require POSIX; + my $tmp_o = POSIX::tmpnam(); my $tmp_e = POSIX::tmpnam(); + local (*OLDOUT, *OLDERR); + + # Try to get a message to the outside world if we die + local $SIG{__DIE__} = sub { print $_[0]; die $_[0] }; + + open(OLDOUT, ">&STDOUT") or die "can't dup stdout: $!"; + open(OLDERR, ">&STDERR") or die "can't dup stderr: $!"; + open(STDOUT, ">$tmp_o") or die "can't open stdout to $tmp_o: $!"; + open(STDERR, ">$tmp_e") or die "can't open stderr to $tmp_e: $!"; + eval $code; + # Doubtful whether most of these messages will ever be seen! + close(STDOUT) or die "cannot close stdout opened to $tmp_o: $!"; + close(STDERR) or die "cannot close stderr opened to $tmp_e: $!"; + open(STDOUT, ">&OLDOUT") or die "can't dup stdout back again: $!"; + open(STDERR, ">&OLDERR") or die "can't dup stderr back again: $!"; + + die $@ if $@; + + local $/ = undef; + open (TMP_O, $tmp_o) or die "cannot open $tmp_o: $!"; + open (TMP_E, $tmp_e) or die "cannot open $tmp_e: $!"; + my $o = ; my $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; + +=head2 Test 1: compilation + +This test confirms that the test script and the modules it calls compiled +successfully. + +=cut + +ok 1, 1, 'compilation'; + +# ------------------------------------- + +$| = 1; + +my $count = 100; + +# Test 2: create a bar +my $test_str = 'test'; + +use vars '$b'; +my $o = grab_output("\$b = new Term::ProgressBar '$test_str', $count"); +if (not $b or $o->[0] ne '' or $o->[1] ne "$test_str: ") { + print Data::Dumper->Dump([$b, $o], [qw( b o )]) + if $ENV{TEST_DEBUG}; + print 'not '; +} +print "ok 2\n"; + +# Test 3: do half the stuff and check half the bar has printed +my $halfway = floor($count / 2); +$o = grab_output("update \$b foreach (0 .. $halfway - 1)"); +if ($o->[0] ne '' + or $o->[1] ne ('#' x floor(50 / 2)) ) +{ + print Data::Dumper->Dump([$o], [qw( o )]) + if $ENV{TEST_DEBUG}; + print 'not '; +} +print "ok 3\n"; + +# Test 4: do the rest of the stuff and check the whole bar has printed +$o = grab_output("update \$b foreach ($halfway .. $count - 1)"); +if ($o->[0] ne '' + or $o->[1] ne ('#' x ceil(50 / 2)) . "\n" ) +{ + print Data::Dumper->Dump([$o], [qw( o )]) + if $ENV{TEST_DEBUG}; + print 'not '; +} +print "ok 4\n"; + +# Test 5: try to do another item and check there is an error +eval { update $b }; +unless ( defined($@) + and + (substr($@, 0, length(Term::ProgressBar::ALREADY_FINISHED)) + eq Term::ProgressBar::ALREADY_FINISHED) ) { + print Data::Dumper->Dump([$@], [qw( @ )]) + if $ENV{TEST_DEBUG}; + print 'not '; +} +print "ok 5\n"; diff --git a/t/eta-linear.t b/t/eta-linear.t new file mode 100644 index 0000000..25081ee --- /dev/null +++ b/t/eta-linear.t @@ -0,0 +1,86 @@ +# (X)Emacs mode: -*- cperl -*- + +use strict; + +=head1 Unit Test Package for Term::ProgressBar + +This package tests the basic functionality of Term::ProgressBar. + +=cut + +use Data::Dumper qw( Dumper ); +use FindBin qw( $Bin ); +use Test qw( ok plan ); + +use lib $Bin; +use test qw( DATA_DIR + evcheck restore_output save_output ); + +BEGIN { + # 1 for compilation test, + plan tests => 10, + todo => [], +} + +=head2 Test 1: compilation + +This test confirms that the test script and the modules it calls compiled +successfully. + +=cut + +use Term::ProgressBar; + +ok 1, 1, 'compilation'; + +Term::ProgressBar->__force_term (50); + +# ------------------------------------- + +=head2 Tests 2--10: Count 1-10 + +Create a progress bar with 10 things. Invoke ETA and name on it. +Update it it from 1 to 10. + +(1) Check no exception thrown on creation +(2) Check no exception thrown on update 1..5 +(3) Check no exception thrown on message issued +(4) Check no exception thrown on update 6..10 +(5) Check message seen +(6) Check bar is complete +(7) Check bar number is 100% +(8) Check --DONE-- issued +(9) Check estimation done + +=cut + +{ + my $p; + save_output('stderr', *STDERR{IO}); + ok (evcheck(sub { + $p = Term::ProgressBar->new({count => 10, name => 'fred', + ETA => 'linear'}); + }, 'Count 1-10 (1)' ), + 1, 'Count 1-10 (1)'); + ok (evcheck(sub { for (1..5) { $p->update($_); sleep 1 } }, + 'Count 1-10 (2)' ), + 1, 'Count 1-10 (2)'); + ok (evcheck(sub { $p->message('Hello Mum!') }, + 'Count 1-10 (3)' ), + 1, 'Count 1-10 (3)'); + ok (evcheck(sub { for (6..10) { $p->update($_); sleep 1 } }, + 'Count 1-10 (4)' ), + 1, 'Count 1-10 (4)'); + my $err = restore_output('stderr'); +# $err =~ s!^.*\r!!gm; + my @lines = grep $_ ne '', split /[\n\r]+/, $err; + print Dumper \@lines + if $ENV{TEST_DEBUG}; + ok grep $_ eq 'Hello Mum!', @lines; + ok $lines[-1], qr/\[=+\]/, 'Count 1-10 (6)'; + ok $lines[-1], qr/^fred: \s*100%/, 'Count 1-10 (7)'; + ok $lines[-1], qr/D[ \d]\dh\d{2}m\d{2}s$/, 'Count 1-10 (8)'; + ok $lines[-2], qr/ Left$/, 'Count 1-10 (9)'; +} + +# ---------------------------------------------------------------------------- diff --git a/t/name.t b/t/name.t new file mode 100644 index 0000000..9b68576 --- /dev/null +++ b/t/name.t @@ -0,0 +1,169 @@ +# (X)Emacs mode: -*- cperl -*- + +use strict; + +=head1 Unit Test Package for Term::ProgressBar + +This package tests the name functionality of Term::ProgressBar. + +=cut + +use Data::Dumper qw( Dumper ); +use FindBin qw( $Bin ); +use Test qw( ok plan ); + +use lib $Bin; +use test qw( DATA_DIR + evcheck restore_output save_output ); + +use constant MESSAGE1 => 'The Gospel of St. Jude'; +use constant NAME1 => 'Algenon'; +use constant NAME2 => 'Smegma'; + +BEGIN { + # 1 for compilation test, + plan tests => 18, + todo => [], +} + +=head2 Test 1: compilation + +This test confirms that the test script and the modules it calls compiled +successfully. + +=cut + +use Term::ProgressBar; + +ok 1, 1, 'compilation'; + +Term::ProgressBar->__force_term (50); + +# ------------------------------------- + +=head2 Tests 2--10: Count 1-10 + +Create a progress bar with 10 things, and a name 'Algenon'. +Update it it from 1 to 10. + +(1) Check no exception thrown on creation +(2) Check no exception thrown on update (1..3) +(3) Check bar number is 30% +(4) Check bar is 30% along +(5) Check no exception thrown on message send +(6) Check no exception thrown on update (6..10) +(7) Check message seen +(8) Check bar is complete +(9) Check bar number is 100% + +=cut + +{ + my $p; + save_output('stderr', *STDERR{IO}); + ok (evcheck(sub { + $p = Term::ProgressBar->new({count => 10, name => NAME1}); + }, 'Count 1-10 ( 1)'), + 1, 'Count 1-10 ( 1)'); + ok (evcheck(sub { $p->update($_) for 1..3 }, 'Count 1-10 ( 2)'), + 1, 'Count 1-10 ( 2)'); + + my $err = restore_output('stderr'); + + $err =~ s!^.*\r!!gm; + print STDERR "ERR (1) :\n$err\nlength: ", length($err), "\n" + if $ENV{TEST_DEBUG}; + my @lines = split /\n/, $err; + ok $lines[-1], qr/^@{[NAME1()]}: \s*\b30%/, 'Count 1-10 ( 3)'; + my ($bar, $space) = $lines[-1] =~ /\[(=*)(\s*)\]/; + my $length = length($bar) + length($space); + print STDERR + ("LENGTHS (1) :BAR:", length($bar), ":SPACE:", length($space), "\n") + if $ENV{TEST_DEBUG}; + my $barexpect = $length * 0.3; + my $ok = length($bar) > $barexpect -1 && length($bar) < $barexpect+1; + ok $ok; + + save_output('stderr', *STDERR{IO}); + + ok (evcheck(sub { $p->message(MESSAGE1) }, 'Count 1-10 ( 5)'), + 1, 'Count 1-10 ( 5)'); + ok (evcheck(sub { $p->update($_) for 6..10 }, 'Count 1-10 ( 6)'), + 1, 'Count 1-10 ( 6)'); + $err = restore_output('stderr'); + + $err =~ s!^.*\r!!gm; + print STDERR "ERR (2) :\n$err\nlength: ", length($err), "\n" + if $ENV{TEST_DEBUG}; + + @lines = split /\n/, $err; + + ok $lines[0], MESSAGE1, 'Count 1-10 ( 7)'; + ok $lines[-1], qr/\[=+\]/, 'Count 1-10 ( 8)'; + ok $lines[-1], qr/^@{[NAME1()]}: \s*100%/, 'Count 1-10 ( 9)'; +} + +# ------------------------------------- + +=head2 Tests 11--20: Count 1-20 + +Create a progress bar with 20 things, and a name 'Smegma'. +Update it it from 1 to 20. +Use v1 mode + +(1) Check no exception thrown on creation +(2) Check no exception thrown on update (1..12) +(3) Check bar number is 60% +(4) Check bar is 60% along +(5) Check no exception thrown on message send +(6) Check no exception thrown on update (13..20) +(7) Check message seen +(8) Check bar is complete +(9) Check bar number is 100% + +=cut + +{ + my $p; + save_output('stderr', *STDERR{IO}); + ok (evcheck(sub { $p = Term::ProgressBar->new(NAME2, 10); }, + 'Count 1-10 ( 1)'), + 1, 'Count 1-10 ( 1)'); + ok (evcheck(sub { $p->update($_) for 1..3 }, 'Count 1-10 ( 2)'), + 1, 'Count 1-10 ( 2)'); + + my $err = restore_output('stderr'); + + $err =~ s!^.*\r!!gm; + print STDERR "ERR (1) :\n$err\nlength: ", length($err), "\n" + if $ENV{TEST_DEBUG}; + my @lines = split /\n/, $err; + ok $lines[-1], qr/^@{[NAME2()]}: \s*\b30%/, 'Count 1-10 ( 3)'; + my ($bar, $space) = $lines[-1] =~ /(\#*)(\s*)/; + my $length = length($bar) + length($space); + print STDERR + ("LENGTHS (1) :BAR:", length($bar), ":SPACE:", length($space), "\n") + if $ENV{TEST_DEBUG}; + my $barexpect = $length * 0.3; + my $ok = length($bar) > $barexpect -1 && length($bar) < $barexpect+1; + ok $ok; + + save_output('stderr', *STDERR{IO}); + + ok (evcheck(sub { $p->message(MESSAGE1) }, 'Count 1-10 ( 5)'), + 1, 'Count 1-10 ( 5)'); + ok (evcheck(sub { $p->update($_) for 6..10 }, 'Count 1-10 ( 6)'), + 1, 'Count 1-10 ( 6)'); + $err = restore_output('stderr'); + + $err =~ s!^.*\r!!gm; + print STDERR "ERR (2) :\n$err\nlength: ", length($err), "\n" + if $ENV{TEST_DEBUG}; + + @lines = split /\n/, $err; + + ok $lines[-1], qr/^@{[NAME2()]}: \s*\d+% \#*$/, 'Count 1-10 ( 8)'; + ok $lines[-1], qr/^@{[NAME2()]}: \s*100%/, 'Count 1-10 ( 9)'; +} + +# ------------------------------------- diff --git a/t/test.pm b/t/test.pm new file mode 100644 index 0000000..59c25cb --- /dev/null +++ b/t/test.pm @@ -0,0 +1,1188 @@ +# (X)Emacs mode: -*- cperl -*- + +package test; + +=head1 NAME + +test - tools for helping in test suites (not including running externalprograms). + +=head1 SYNOPSIS + + use FindBin 1.42 qw( $Bin ); + use Test 1.13 qw( ok plan ); + + BEGIN { unshift @INC, $Bin }; + + use test qw( DATA_DIR + evcheck runcheck ); + + BEGIN { + plan tests => 3, + todo => [], + ; + } + + ok evcheck(sub { + open my $fh, '>', 'foo'; + print $fh "$_\n" + for 'Bulgaria', 'Cholet'; + close $fh; + }, 'write foo'), 1, 'write foo'; + + save_output('stderr', *STDERR{IO}); + warn 'Hello, Mum!'; + print restore_output('stderr'); + +=head1 DESCRIPTION + +This package provides some variables, and sets up an environment, for test +scripts, such as those used in F. + +This package does not including running external programs; that is provided by +C. This is so that suites not needing that can include only +test.pm, and so not require the presence of C. + +Setting up the environment includes: + +=over 4 + +=item Prepending F onto the path + +=item Pushing the module F dir onto the @PERL5LIB var + +For executed scripts. + +=item Pushing the module F dir onto the @INC var + +For internal C 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) + +=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). + +=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 or L, but does not get deleted +if TEST_DEBUG has SAVE in the value. + +=over 4 + +=item ARGUMENTS + +=over 4 + +=item name + +I. 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 or L, but does not get deleted +if TEST_DEBUG has SAVE in the value (does get deleted otherwise). + +=over 4 + +=item ARGUMENTS + +I + +=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 File to compare + +=item fn2 + +B File to compare + +=item name + +B Test name + +=item sort + +B sort files prior to comparison. Requires the C command to +be on C<$PATH> (else skips). + +=item gunzip + +B gunzip files prior to comparison. Requires the C command to +be on C<$PATH> (else skips). gzip occurs prior to any sort. + +=item untar + +B untar files prior to comparison. Requires the C 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 = ; +#XYZ my $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 +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. + +=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 + +=item line-terminator + +B. 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 + +=head1 COPYRIGHT + +Copyright (c) 2001, 2002, 2004 Martyn J. Pearce. This program is free +software; you can redistribute it and/or modify it under the same terms as +Perl itself. + +=head1 SEE ALSO + +Z<> + +=cut + +1; # keep require happy. + +__END__ diff --git a/t/v1-message.t b/t/v1-message.t new file mode 100644 index 0000000..a34917d --- /dev/null +++ b/t/v1-message.t @@ -0,0 +1,80 @@ +# (X)Emacs mode: -*- cperl -*- + +use strict; + +=head1 Unit Test Package for Term::ProgressBar + +This package tests the basic functionality of Term::ProgressBar. + +=cut + +use Data::Dumper qw( Dumper ); +use FindBin qw( $Bin ); +use Test qw( ok plan ); + +use lib $Bin; +use test qw( DATA_DIR + evcheck restore_output save_output ); + +use constant MESSAGE1 => 'Walking on the Milky Way'; + +BEGIN { + # 1 for compilation test, + plan tests => 8, + todo => [], +} + +=head2 Test 1: compilation + +This test confirms that the test script and the modules it calls compiled +successfully. + +=cut + +use Term::ProgressBar; + +ok 1, 1, 'compilation'; + +Term::ProgressBar->__force_term (50); + +# ------------------------------------- + +=head2 Tests 2--8: Count 1-10 + +Create a progress bar with 10 things, and a name 'bob'. +Update it it from 1 to 10. + +(1) Check no exception thrown on creation +(2) Check no exception thrown on update (1..5) +(3) Check no exception thrown on message send +(4) Check no exception thrown on update (6..10) +(5) Check message output. +(5) Check bar is complete +(6) Check bar number is 100% + +=cut + +{ + my $p; + save_output('stderr', *STDERR{IO}); + ok (evcheck(sub { $p = Term::ProgressBar->new('bob', 10); }, + 'Count 1-10 (1)' ), + 1, 'Count 1-10 (1)'); + ok (evcheck(sub { $p->update($_) for 1..5 }, 'Count 1-10 (2)' ), + 1, 'Count 1-10 (2)'); + ok (evcheck(sub { $p->message(MESSAGE1) }, 'Count 1-10 (3)' ), + 1, 'Count 1-10 (3)'); + ok (evcheck(sub { $p->update($_) for 6..10 }, 'Count 1-10 (4)' ), + 1, 'Count 1-10 (4)'); + my $err = restore_output('stderr'); + + $err =~ s!^.*\r!!gm; + print STDERR "ERR:\n$err\nlength: ", length($err), "\n" + if $ENV{TEST_DEBUG}; + + my @lines = split /\n/, $err; + + ok $lines[0], MESSAGE1; + ok $lines[-1], qr/bob:\s+\d+% \#+/, 'Count 1-10 (6)'; + ok $lines[-1], qr/^bob:\s+100%/, 'Count 1-10 (7)'; +} diff --git a/t/v2-message.t b/t/v2-message.t new file mode 100644 index 0000000..3563495 --- /dev/null +++ b/t/v2-message.t @@ -0,0 +1,109 @@ +# (X)Emacs mode: -*- cperl -*- + +use strict; + +=head1 Unit Test Package for Term::ProgressBar + +This package tests the basic functionality of Term::ProgressBar. + +=cut + +use Data::Dumper 2.101 qw( Dumper ); +use FindBin 1.42 qw( $Bin ); +use Test 1.122 qw( ok plan ); + +use lib $Bin; +use test qw( DATA_DIR + evcheck restore_output save_output ); + +use constant MESSAGE1 => 'Walking on the Milky Way'; + +BEGIN { + # 1 for compilation test, + plan tests => 11, + todo => [], +} + +=head2 Test 1: compilation + +This test confirms that the test script and the modules it calls compiled +successfully. + +=cut + +use Term::ProgressBar; + +ok 1, 1, 'compilation'; + +Term::ProgressBar->__force_term (50); + +# ------------------------------------- + +=head2 Tests 2--8: Count 1-10 + +Create a progress bar with 10 things. +Update it it from 1 to 10. Output a message halfway through. + +(1) Check no exception thrown on creation +(2) Check no exception thrown on update (1..5) +(3) Check no exception thrown on message send +(4) Check no exception thrown on update (6..10) +(5) Check message was issued. +(6) Check bar is complete +(7) Check bar number is 100% + +=cut + +{ + my $p; + save_output('stderr', *STDERR{IO}); + ok (evcheck(sub { $p = Term::ProgressBar->new(10); }, 'Count 1-10 (1)' ), + 1, 'Count 1-10 (1)'); + ok (evcheck(sub { $p->update($_) for 1..5 }, 'Count 1-10 (2)' ), + 1, 'Count 1-10 (2)'); + ok (evcheck(sub { $p->message(MESSAGE1) }, 'Count 1-10 (3)' ), + 1, 'Count 1-10 (3)'); + ok (evcheck(sub { $p->update($_) for 6..10 }, 'Count 1-10 (4)' ), + 1, 'Count 1-10 (4)'); + my $err = restore_output('stderr'); + + $err =~ s!^.*\r!!gm; + print STDERR "ERR:\n$err\nlength: ", length($err), "\n" + if $ENV{TEST_DEBUG}; + + my @lines = split /\n/, $err; + + ok $lines[0], MESSAGE1; + ok $lines[-1], qr/\[=+\]/, 'Count 1-10 (5)'; + ok $lines[-1], qr/^\s*100%/, 'Count 1-10 (6)'; +} + +# ------------------------------------- + +=head2 Tests 9--11: Message Check + +Run a progress bar from 0 to 100, each time calling a message after an update. +This is to check that message preserves the progress bar value correctly. + +( 1) Check no exception thrown on creation +( 2) Check no exception thrown on update, message (0..100). +( 3) Check last progress is 100% + +=cut + +{ + my $p; + save_output('stderr', *STDERR{IO}); + ok (evcheck(sub { $p = Term::ProgressBar->new(100); }, 'Message Check ( 1)'), + 1, 'Message Check ( 1)'); + ok (evcheck(sub { for (0..100) { $p->update($_); $p->message("Hello") } }, + 'Message Check ( 2)',), + 1, 'Message Check ( 2)'); + my $err = restore_output('stderr'); + + my @err_lines = split /\n/, $err; + (my $last_line = $err_lines[-1]) =~ tr/\r//d; + ok substr($last_line, 0, 4), '100%', 'Message Check ( 3)'; +} + +# ---------------------------------------------------------------------------- diff --git a/t/v2-mobile.t b/t/v2-mobile.t new file mode 100644 index 0000000..c851278 --- /dev/null +++ b/t/v2-mobile.t @@ -0,0 +1,77 @@ +# (X)Emacs mode: -*- cperl -*- + +use strict; + +=head1 Unit Test Package for Term::ProgressBar + +This package tests the moving target functionality of Term::ProgressBar. + +=cut + +use Data::Dumper qw( Dumper ); +use FindBin qw( $Bin ); +use Test qw( ok plan ); + +use lib $Bin; +use test qw( DATA_DIR + evcheck restore_output save_output ); + +BEGIN { + # 1 for compilation test, + plan tests => 7, + todo => [], +} + +=head2 Test 1: compilation + +This test confirms that the test script and the modules it calls compiled +successfully. + +=cut + +use Term::ProgressBar; + +ok 1, 1, 'compilation'; + +Term::ProgressBar->__force_term (50); + +# ------------------------------------- + +=head2 Tests 2--7: Count 1-20 + +Create a progress bar with 10 things. +Update it it from 1 to 5. +Change target to 20. +Update it from 11 to 20. + +(1) Check no exception thrown on creation +(2) Check no exception thrown on update (1..5) +(3) Check no exception thrown on target update +(4) Check no exception thrown on update (6..10) +(5) Check bar is complete +(6) Check bar number is 100% + +=cut + +{ + my $p; + save_output('stderr', *STDERR{IO}); + ok (evcheck(sub { $p = Term::ProgressBar->new(10); }, 'Count 1-20 (1)' ), + 1, 'Count 1-20 (1)'); + ok (evcheck(sub { $p->update($_) for 1..5 }, 'Count 1-20 (2)' ), + 1, 'Count 1-20 (2)'); + ok (evcheck(sub { $p->target(20) }, 'Count 1-20 (3)' ), + 1, 'Count 1-20 (3)'); + ok (evcheck(sub { $p->update($_) for 11..20 }, 'Count 1-20 (4)' ), + 1, 'Count 1-20 (4)'); + my $err = restore_output('stderr'); + + $err =~ s!^.*\r!!gm; + print STDERR "ERR:\n$err\nlength: ", length($err), "\n" + if $ENV{TEST_DEBUG}; + + my @lines = split /\n/, $err; + + ok $lines[-1], qr/\[=+\]/, 'Count 1-20 (5)'; + ok $lines[-1], qr/^\s*100%/, 'Count 1-20 (6)'; +} diff --git a/t/v2-simple.t b/t/v2-simple.t new file mode 100644 index 0000000..83015fd --- /dev/null +++ b/t/v2-simple.t @@ -0,0 +1,120 @@ +# (X)Emacs mode: -*- cperl -*- + +use strict; + +=head1 Unit Test Package for Term::ProgressBar + +This package tests the basic functionality of Term::ProgressBar. + +=cut + +use Data::Dumper qw( Dumper ); +use FindBin qw( $Bin ); +use Test qw( ok plan ); + +use lib $Bin; +use test qw( DATA_DIR + evcheck restore_output save_output ); + +BEGIN { + # 1 for compilation test, + plan tests => 31, + todo => [], +} + +=head2 Test 1: compilation + +This test confirms that the test script and the modules it calls compiled +successfully. + +=cut + +use Term::ProgressBar; + +ok 1, 1, 'compilation'; + +Term::ProgressBar->__force_term (50); + +# ------------------------------------- + +=head2 Tests 2--16: Count 1-10 + +Create a progress bar with 10 things. +Update it it from 1 to 10. + +(1) Check no exception thrown on creation +(2) Check no exception thrown on update +(3) Check bar is complete +(4) Check bar number is 100% +(5--15) Check bar has no minor characters at any point + +=cut + +{ + my $p; + save_output('stderr', *STDERR{IO}); + ok (evcheck(sub { $p = Term::ProgressBar->new(10); }, 'Count 1-10 (1)' ), + 1, 'Count 1-10 (1)'); + ok (evcheck(sub { $p->update($_) for 1..10 }, 'Count 1-10 (2)' ), + 1, 'Count 1-10 (2)'); + my $err = restore_output('stderr'); + my @lines = grep $_ ne '', split /\r/, $err; + print Dumper \@lines + if $ENV{TEST_DEBUG}; + ok $lines[-1], qr/\[=+\]/, 'Count 1-10 (3)'; + ok $lines[-1], qr/^\s*100%/, 'Count 1-10 (4)'; + ok $lines[$_], qr/\[[= ]+\]/, sprintf('Count 1-10 (%d)', 5+$_) + for 0..10; +} + +# ------------------------------------- + +=head2 Tests 17--30: Count 1-9 + +Create a progress bar with 10 things. +Update it it from 1 to 9. + +(1) Check no exception thrown on creation +(2) Check no exception thrown on update +(3) Check bar is incomplete +(4) Check bar number is 90% +(5--14) Check bar has no minor characters at any point + +=cut + +{ + my $p; + save_output('stderr', *STDERR{IO}); + ok (evcheck(sub { $p = Term::ProgressBar->new(10); }, 'Count 1-9 (1)' ), + 1, 'Count 1-9 (1)'); + ok (evcheck(sub { $p->update($_) for 1..9 }, 'Count 1-9 (2)' ), + 1, 'Count 1-9 (2)'); + my $err = restore_output('stderr'); + my @lines = grep $_ ne '', split /\r/, $err; + print Dumper \@lines + if $ENV{TEST_DEBUG}; + ok $lines[-1], qr/\[=+ +\]/, 'Count 1-9 (3)'; + ok $lines[-1], qr/^\s*90%/, 'Count 1-9 (4)'; + ok $lines[$_], qr/\[[= ]+\]/, sprintf('Count 1-9 (%d)', 5+$_) + for 0..9; +} + +# ------------------------------------- + +=head2 Test 31 + +Make sure the same progress bar text is not printed twice to the +terminal (in the case of an update that is too little to affect the +percentage or displayed bar). + +=cut +{ + save_output('stderr', *STDERR{IO}); + my $b = Term::ProgressBar->new(1000000); + $b->update($_) foreach (0, 1); + my $err = restore_output('stderr'); + my @lines = grep $_ ne '', split /\r/, $err; + print Dumper \@lines + if $ENV{TEST_DEBUG}; + ok scalar @lines, 1; +} diff --git a/t/zero.t b/t/zero.t new file mode 100644 index 0000000..737f508 --- /dev/null +++ b/t/zero.t @@ -0,0 +1,101 @@ +# (X)Emacs mode: -*- cperl -*- + +use strict; + +=head1 Unit Test Package for Term::ProgressBar + +This package tests the zero-progress handling of progress bar. + +=cut + +use Data::Dumper qw( Dumper ); +use FindBin qw( $Bin ); +use Test qw( ok plan ); + +use lib $Bin; +use test qw( DATA_DIR + evcheck restore_output save_output ); + +BEGIN { + # 1 for compilation test, + plan tests => 9, + todo => [], +} + +=head2 Test 1: compilation + +This test confirms that the test script and the modules it calls compiled +successfully. + +=cut + +use Term::ProgressBar; + +ok 1, 1, 'compilation'; + +Term::ProgressBar->__force_term (50); + +# ------------------------------------- + +=head2 Tests 2--5: V1 mode + +Create a progress bar with 0 things. +Update it it from 1 to 10. + +(1) Check no exception thrown on creation +(2) Check no exception thrown on update +(3) Check bar displays name +(3) Check bar says nothing to do + +=cut + +{ + my $p; + save_output('stderr', *STDERR{IO}); + my $name = 'doing nothing'; + ok (evcheck(sub { $p = Term::ProgressBar->new($name, 0); }, + 'V1 mode ( 1)' ), + 1, 'V1 mode ( 1)'); + ok (evcheck(sub { $p->update($_) for 1..10 },'V1 mode ( 2)'), + 1, 'V1 mode ( 2)'); + my $err = restore_output('stderr'); + my @lines = grep $_ ne '', split /\r/, $err; + print Dumper \@lines + if $ENV{TEST_DEBUG}; + ok $lines[-1], qr/^$name:/, 'V1 mode ( 3)'; + ok $lines[-1], qr/\(nothing to do\)/, 'V1 mode ( 4)'; +} + +# ------------------------------------- + +=head2 Tests 6--9: V2 mode + +Create a progress bar with 0 things. +Update it it from 1 to 10. + +(1) Check no exception thrown on creation +(2) Check no exception thrown on update +(3) Check bar displays name +(4) Check bar says nothing to do + +=cut + +{ + my $p; + save_output('stderr', *STDERR{IO}); + my $name = 'zero'; + ok (evcheck(sub { $p = Term::ProgressBar->new({ count => 0, + name => $name }); }, + 'V2 mode ( 1)' ), + 1, 'V2 mode ( 1)'); + ok (evcheck(sub { $p->update($_) for 1..10 },'V2 mode ( 2)'), + 1, 'V2 mode ( 2)'); + my $err = restore_output('stderr'); + my @lines = grep $_ ne '', split /\r/, $err; + print Dumper \@lines + if $ENV{TEST_DEBUG}; + ok $lines[-1], qr/^$name:/, 'V2 mode ( 3)'; + ok $lines[-1], qr/\(nothing to do\)/, 'V2 mode ( 4)'; +} + +# ---------------------------------------------------------------------------- -- 2.39.2