use Test qw( ok plan );
use lib $Bin;
-use test qw(
- evcheck restore_output save_output );
+use test qw( evcheck );
BEGIN {
# 1 for compilation test,
=cut
-{
+use Capture::Tiny qw(capture);
+
+my ($out, $err) = capture {
my $p;
- save_output('stderr', *STDERR{IO});
ok (evcheck(sub {
$p = Term::ProgressBar->new({count => 10, name => 'fred',
ETA => 'linear'});
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;
+};
+print $out;
my @lines = grep $_ ne '', split /[\n\r]+/, $err;
print Dumper \@lines
if $ENV{TEST_DEBUG};
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)';
-}
+
# ----------------------------------------------------------------------------
use Test qw( ok plan );
use lib $Bin;
-use test qw(
- evcheck restore_output save_output );
+use test qw( evcheck );
use constant MESSAGE1 => 'The Gospel of St. Jude';
use constant NAME1 => 'Algenon';
=cut
+use Capture::Tiny qw(capture);
+
{
my $p;
- save_output('stderr', *STDERR{IO});
+my ($out, $err) = capture {
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');
+};
+print $out;
$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);
my $ok = length($bar) > $barexpect -1 && length($bar) < $barexpect+1;
ok $ok;
- save_output('stderr', *STDERR{IO});
+($out, $err) = capture {
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');
+};
+print $out;
$err =~ s!^.*\r!!gm;
print STDERR "ERR (2) :\n$err\nlength: ", length($err), "\n"
{
my $p;
- save_output('stderr', *STDERR{IO});
+my ($out, $err) = capture {
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');
+};
+print $out;
$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);
my $barexpect = $length * 0.3;
my $ok = length($bar) > $barexpect -1 && length($bar) < $barexpect+1;
ok $ok;
-
- save_output('stderr', *STDERR{IO});
-
+
+($out, $err) = capture {
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');
-
+};
+print $out;
$err =~ s!^.*\r!!gm;
print STDERR "ERR (2) :\n$err\nlength: ", length($err), "\n"
if $ENV{TEST_DEBUG};
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
=item evcheck
-=item save_output
-
-=item restore_output
-
-=item tmpnam
-
-=item tempdir
-
=back
=cut
-@EXPORT_OK = qw( evcheck save_output restore_output );
+@EXPORT_OK = qw( evcheck );
# Utility -----------------------------
use File::Basename qw( basename );
use File::Path 1.0401 qw( mkpath rmtree );
use File::Spec 0.6 qw( );
+use File::Temp qw( tempdir );
use FindBin 1.42 qw( $Bin );
-use POSIX 1.02 qw( );
+#use POSIX 1.02 qw( );
use Test 1.122 qw( ok skip );
# ----------------------------------------------------------------------------
$PATH = join ':', BUILD_SCRIPT_DIR, split /:/, $PATH;
-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;
-
-chdir $tmpdn;
-
# -------------------------------------
# PACKAGE FUNCTIONS
# -------------------------------------
# -------------------------------------
-=head2 save_output
-
-Redirect a filehandle to temporary storage for later examination.
-
-=over 4
-
-=item ARGUMENTS
-
-=over 4
-
-=item name
-
-Name to store as (used in L<restore_output>)
-
-=item filehandle
-
-The filehandle to save
-
-=back
-
-=cut
-
-# Map from names to saved filehandles.
-
-# Values are arrayrefs, being filehandle that was saved (to restore), the
-# filehandle being printed to in the meantime, and the original filehandle.
-# This may be treated as a stack; to allow multiple saves... push & pop this
-# stack.
-
-my %grabs;
-
-sub save_output {
- croak sprintf("%s takes 2 arguments\n", (caller 0)[3])
- unless @_ == 2;
- my ($name, $filehandle) = @_;
-
- my $tmpfh = do { local *F; *F; };
- my $savefh = do { local *F; *F; };
-
- (undef, $tmpfh) = test::tmpnam();
- select((select($tmpfh), $| = 1)[0]);
-
- open $savefh, '>&' . fileno $filehandle
- or die "can't dup $name: $!";
- open $filehandle, '>&' . fileno $tmpfh
- or die "can't open $name to tempfile: $!";
-
- push @{$grabs{$name}}, $savefh, $tmpfh, $filehandle;
-}
-
-# -------------------------------------
-
-=head2 restore_output
-
-Restore a saved filehandle to its original state, return the saved output.
-
-=over 4
-
-=item ARGUMENTS
-
-=over 4
-
-=item name
-
-Name of the filehandle to restore (as passed to L<save_output>).
-
-=back
-
-=item RETURNS
-
-=over 4
-
-=item saved_string
-
-A single string being the output saved.
-
-=back
-
-=cut
-
-sub restore_output {
- my ($name) = @_;
-
- croak "$name has not been saved\n"
- unless exists $grabs{$name};
- croak "All saved instances of $name have been restored\n"
- unless @{$grabs{$name}};
- my ($savefh, $tmpfh, $origfh) = splice @{$grabs{$name}}, -3;
-
- close $origfh
- or die "cannot close $name opened to tempfile: $!";
- open $origfh, '>&' . fileno $savefh
- or die "cannot dup $name back again: $!";
- select((select($origfh), $| = 1)[0]);
-
- seek $tmpfh, 0, 0;
- local $/ = undef;
- my $string = <$tmpfh>;
- close $tmpfh;
-
- return $string;
-}
-
-# -------------------------------------
-
-=head2 tmpnam
-
-Very much like the one in L<POSIX> or L<File::Temp>, but does not get deleted
-if TEST_DEBUG has SAVE in the value.
-
-=over 4
-
-=item ARGUMENTS
-
-=over 4
-
-=item name
-
-I<Optional>. If defined, a name by which to refer to the tmpfile in user
-messages.
-
-=back
-
-=item RETURNS
-
-=over 4
-
-=item filename
-
-Name of temporary file.
-
-=item fh
-
-Open filehandle to temp file, in r/w mode. Only created & returned in list
-context.
-
-=back
-
-=back
-
-=cut
-
-my @tmpfns;
-
-BEGIN {
- my $savewarn = $SIG{__WARN__};
- # Subvert bizarre (& incorrect) subroutine redefined errors in 5.005_03
- local $SIG{__WARN__} =
- sub {
- $savewarn->(@_)
- if defined $savewarn and
- UNIVERSAL::isa($savewarn,'CODE') and
- $_[0] !~ /^Subroutine tmpnam redefined/;
- };
-
- *tmpnam = sub {
- my $tmpnam = POSIX::tmpnam;
-
- if (@_) {
- push @tmpfns, [ $tmpnam, $_[0] ];
- } else {
- push @tmpfns, $tmpnam;
- }
-
- if (wantarray) {
- sysopen my $tmpfh, $tmpnam, O_RDWR | O_CREAT | O_EXCL;
- return $tmpnam, $tmpfh;
- } else {
- return $tmpnam;
- }
- }
-}
-
-END {
- if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) {
- for (@tmpfns) {
- if ( ref $_ ) {
- printf "Used temp file: %s (%s)\n", @$_;
- } else {
- print "Used temp file: $_\n";
- }
- }
- } else {
- unlink map((ref $_ ? $_->[0] : $_), @tmpfns)
- if @tmpfns;
- }
-}
-
-# -------------------------------------
-
-=head2 tempdir
-
-Very much like the one in L<POSIX> or L<File::Temp>, but does not get deleted
-if TEST_DEBUG has SAVE in the value (does get deleted otherwise).
-
-=over 4
-
-=item ARGUMENTS
-
-I<None>
-
-=item RETURNS
-
-=over 4
-
-=item name
-
-Name of temporary dir.
-
-=back
-
-=back
-
-=cut
-
-my @tmpdirs;
-sub tempdir {
- my $tempdir = POSIX::tmpnam;
- mkdir $tempdir, 0700
- or die "Failed to create temporary directory $tempdir: $!\n";
-
- if (@_) {
- push @tmpdirs, [ $tempdir, $_[0] ];
- } else {
- push @tmpdirs, $tempdir;
- }
-
- return $tempdir;
-}
-
-END {
- for (@tmpdirs) {
- if ( ref $_ ) {
- if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) {
- printf "Used temp dir: %s (%s)\n", @$_;
- } else {
- # Solaris gets narky about removing the pwd.
- chdir File::Spec->rootdir;
- rmtree $_->[0];
- }
- } else {
- if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) {
- print "Used temp dir: $_\n";
- } else {
- # Solaris gets narky about removing the pwd.
- chdir File::Spec->rootdir;
- rmtree $_;
- }
- }
- }
-}
-
-
# defined further up to use in constants
# ----------------------------------------------------------------------------
use Test qw( ok plan );
use lib $Bin;
-use test qw( evcheck restore_output save_output );
+use test qw( evcheck );
use constant MESSAGE1 => 'Walking on the Milky Way';
(6) Check bar number is 100%
=cut
+use Capture::Tiny qw(capture);
-{
+my ($out, $err) = capture {
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)');
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');
+};
+print $out;
$err =~ s!^.*\r!!gm;
print STDERR "ERR:\n$err\nlength: ", length($err), "\n"
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)';
-}
use Test 1.122 qw( ok plan );
use lib $Bin;
-use test qw( evcheck restore_output save_output );
+use test qw( evcheck );
use constant MESSAGE1 => 'Walking on the Milky Way';
+use Capture::Tiny qw(capture);
+
BEGIN {
# 1 for compilation test,
plan tests => 11,
=cut
-{
+my ($out, $err) = capture {
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 (3)');
ok (evcheck(sub { $p->update($_) for 6..10 }, 'Count 1-10 (4)' ),
1, 'Count 1-10 (4)');
- my $err = restore_output('stderr');
+};
+print $out;
$err =~ s!^.*\r!!gm;
print STDERR "ERR:\n$err\nlength: ", length($err), "\n"
ok $lines[0], MESSAGE1;
ok $lines[-1], qr/\[=+\]/, 'Count 1-10 (5)';
ok $lines[-1], qr/^\s*100%/, 'Count 1-10 (6)';
-}
# -------------------------------------
=cut
-{
+($out, $err) = capture {
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');
+};
+print $out;
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)';
-}
# ----------------------------------------------------------------------------
use Test qw( ok plan );
use lib $Bin;
-use test qw( evcheck restore_output save_output );
+use test qw( evcheck );
+
+use Capture::Tiny qw(capture);
BEGIN {
# 1 for compilation test,
=cut
-{
+my ($out, $err) = capture {
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 (3)');
ok (evcheck(sub { $p->update($_) for 11..20 }, 'Count 1-20 (4)' ),
1, 'Count 1-20 (4)');
- my $err = restore_output('stderr');
+};
+print $out;
$err =~ s!^.*\r!!gm;
print STDERR "ERR:\n$err\nlength: ", length($err), "\n"
ok $lines[-1], qr/\[=+\]/, 'Count 1-20 (5)';
ok $lines[-1], qr/^\s*100%/, 'Count 1-20 (6)';
-}
use Test qw( ok plan );
use lib $Bin;
-use test qw( evcheck restore_output save_output );
+use test qw( evcheck );
+
+use Capture::Tiny qw(capture);
BEGIN {
# 1 for compilation test,
(5--15) Check bar has no minor characters at any point
=cut
-
{
my $p;
- save_output('stderr', *STDERR{IO});
+
+my ($out, $err) = capture {
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');
+};
+print $out;
my @lines = grep $_ ne '', split /\r/, $err;
print Dumper \@lines
if $ENV{TEST_DEBUG};
ok $lines[$_], qr/\[[= ]+\]/, sprintf('Count 1-10 (%d)', 5+$_)
for 0..10;
}
-
# -------------------------------------
=head2 Tests 17--30: Count 1-9
{
my $p;
- save_output('stderr', *STDERR{IO});
+
+my ($out, $err) = capture {
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');
+};
+print $out;
+
my @lines = grep $_ ne '', split /\r/, $err;
print Dumper \@lines
if $ENV{TEST_DEBUG};
ok $lines[$_], qr/\[[= ]+\]/, sprintf('Count 1-9 (%d)', 5+$_)
for 0..9;
}
-
# -------------------------------------
=head2 Test 31
=cut
{
- save_output('stderr', *STDERR{IO});
+my ($out, $err) = capture {
my $b = Term::ProgressBar->new(1000000);
$b->update($_) foreach (0, 1);
- my $err = restore_output('stderr');
+};
+print $out;
my @lines = grep $_ ne '', split /\r/, $err;
print Dumper \@lines
if $ENV{TEST_DEBUG};
use FindBin qw( $Bin );
use Test qw( ok plan );
+use Capture::Tiny qw(capture);
+
use lib $Bin;
-use test qw( evcheck restore_output save_output );
+use test qw( evcheck );
BEGIN {
# 1 for compilation test,
{
my $p;
- save_output('stderr', *STDERR{IO});
- my $name = 'doing nothing';
+ my $name;
+my ($out, $err) = capture {
+ $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');
+};
+print $out;
my @lines = grep $_ ne '', split /\r/, $err;
print Dumper \@lines
if $ENV{TEST_DEBUG};
{
my $p;
- save_output('stderr', *STDERR{IO});
my $name = 'zero';
+my ($out, $err) = capture {
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');
+};
+print $out;
my @lines = grep $_ ne '', split /\r/, $err;
print Dumper \@lines
if $ENV{TEST_DEBUG};