X-Git-Url: https://git.donarmstrong.com/?p=term-progressbar.git;a=blobdiff_plain;f=t%2Ftest.pm;h=c10aa57dff118abb548fec603c304c81d4e920d9;hp=99648089f171a95bfe7012f8eeab4f8c1eb65b10;hb=c117fc5047ab77ee6df1d6a7c6a595a3ebc87d00;hpb=f4194368a3b33761e053166dde55a807b7a81ddb 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 # ----------------------------------------------------------------------------