From: Gabor Szabo Date: Tue, 29 Nov 2011 13:06:38 +0000 (+0200) Subject: import Term-ProgressBar-2.09 from CPAN X-Git-Url: https://git.donarmstrong.com/?p=term-progressbar.git;a=commitdiff_plain;h=3797cda1b0da9caa24c7ff35e910e1f318c77918 import Term-ProgressBar-2.09 from CPAN --- 3797cda1b0da9caa24c7ff35e910e1f318c77918 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)'; +} + +# ----------------------------------------------------------------------------