From c117fc5047ab77ee6df1d6a7c6a595a3ebc87d00 Mon Sep 17 00:00:00 2001 From: Gabor Szabo Date: Tue, 29 Nov 2011 18:50:46 +0200 Subject: [PATCH] replace the home made capturing of stderr by usage of Capture::Tiny --- t/eta-linear.t | 14 +-- t/name.t | 33 +++--- t/test.pm | 277 +------------------------------------------------ t/v1-message.t | 10 +- t/v2-message.t | 18 ++-- t/v2-mobile.t | 11 +- t/v2-simple.t | 25 +++-- t/zero.t | 17 +-- 8 files changed, 74 insertions(+), 331 deletions(-) diff --git a/t/eta-linear.t b/t/eta-linear.t index 02189d5..0de0594 100644 --- a/t/eta-linear.t +++ b/t/eta-linear.t @@ -13,8 +13,7 @@ use FindBin qw( $Bin ); 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, @@ -54,9 +53,10 @@ Update it it from 1 to 10. =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'}); @@ -71,8 +71,8 @@ Update it it from 1 to 10. 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}; @@ -81,6 +81,6 @@ Update it it from 1 to 10. 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 index f5ac387..09ea432 100644 --- a/t/name.t +++ b/t/name.t @@ -13,8 +13,7 @@ use FindBin qw( $Bin ); 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'; @@ -58,22 +57,25 @@ Update it it from 1 to 10. =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); @@ -84,13 +86,14 @@ Update it it from 1 to 10. 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" @@ -125,19 +128,20 @@ Use v1 mode { 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); @@ -147,15 +151,14 @@ Use v1 mode 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}; diff --git a/t/test.pm b/t/test.pm index 9964808..c10aa57 100644 --- a/t/test.pm +++ b/t/test.pm @@ -28,10 +28,6 @@ test - tools for helping in test suites (not including running externalprograms) 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 @@ -84,19 +80,11 @@ The following symbols are exported upon request: =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 ----------------------------- @@ -108,8 +96,9 @@ use Fcntl 1.03 qw( :DEFAULT ); 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 ); # ---------------------------------------------------------------------------- @@ -126,15 +115,8 @@ use constant BUILD_SCRIPT_DIR => => File::Spec->catdir( $Bin, File::Spec->updir, $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 # ------------------------------------- @@ -192,259 +174,6 @@ sub evcheck { # ------------------------------------- -=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; -} - -# ------------------------------------- - -=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 $_; - } - } - } -} - - # defined further up to use in constants # ---------------------------------------------------------------------------- diff --git a/t/v1-message.t b/t/v1-message.t index f0b4fb1..550ab79 100644 --- a/t/v1-message.t +++ b/t/v1-message.t @@ -13,7 +13,7 @@ use FindBin qw( $Bin ); 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'; @@ -52,10 +52,10 @@ Update it it from 1 to 10. (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)'); @@ -65,7 +65,8 @@ Update it it from 1 to 10. 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" @@ -76,4 +77,3 @@ Update it it from 1 to 10. 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 index 38868db..5b215be 100644 --- a/t/v2-message.t +++ b/t/v2-message.t @@ -13,10 +13,12 @@ use FindBin 1.42 qw( $Bin ); 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, @@ -53,9 +55,8 @@ Update it it from 1 to 10. Output a message halfway through. =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)' ), @@ -64,7 +65,8 @@ Update it it from 1 to 10. Output a message halfway through. 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" @@ -75,7 +77,6 @@ Update it it from 1 to 10. Output a message halfway through. ok $lines[0], MESSAGE1; ok $lines[-1], qr/\[=+\]/, 'Count 1-10 (5)'; ok $lines[-1], qr/^\s*100%/, 'Count 1-10 (6)'; -} # ------------------------------------- @@ -90,19 +91,18 @@ This is to check that message preserves the progress bar value correctly. =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)'; -} # ---------------------------------------------------------------------------- diff --git a/t/v2-mobile.t b/t/v2-mobile.t index 6f8f67c..dca4062 100644 --- a/t/v2-mobile.t +++ b/t/v2-mobile.t @@ -13,7 +13,9 @@ use FindBin qw( $Bin ); 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, @@ -52,9 +54,8 @@ Update it from 11 to 20. =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)' ), @@ -63,7 +64,8 @@ Update it from 11 to 20. 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" @@ -73,4 +75,3 @@ Update it from 11 to 20. 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 index a95d93d..5b300ba 100644 --- a/t/v2-simple.t +++ b/t/v2-simple.t @@ -13,7 +13,9 @@ use FindBin qw( $Bin ); 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, @@ -48,15 +50,16 @@ Update it it from 1 to 10. (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}; @@ -65,7 +68,6 @@ Update it it from 1 to 10. ok $lines[$_], qr/\[[= ]+\]/, sprintf('Count 1-10 (%d)', 5+$_) for 0..10; } - # ------------------------------------- =head2 Tests 17--30: Count 1-9 @@ -83,12 +85,15 @@ Update it it from 1 to 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}; @@ -97,7 +102,6 @@ Update it it from 1 to 9. ok $lines[$_], qr/\[[= ]+\]/, sprintf('Count 1-9 (%d)', 5+$_) for 0..9; } - # ------------------------------------- =head2 Test 31 @@ -108,10 +112,11 @@ percentage or displayed bar). =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}; diff --git a/t/zero.t b/t/zero.t index e857a59..7461163 100644 --- a/t/zero.t +++ b/t/zero.t @@ -12,8 +12,10 @@ use Data::Dumper qw( Dumper ); 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, @@ -50,14 +52,16 @@ Update it it from 1 to 10. { 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}; @@ -81,15 +85,16 @@ Update it it from 1 to 10. { 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}; -- 2.39.2