X-Git-Url: https://git.donarmstrong.com/?p=term-progressbar.git;a=blobdiff_plain;f=t%2Ftest.pm;h=f72ae085821bc3aec006892ee6c97bd40737d4dc;hp=49ed95a9014b112245c22f41245fd5a29dcb03e5;hb=8f87af0520c5dbcedbfe74dd6ef6e7826f200263;hpb=fc498c99ddaa51b003d7b6f9b2f5533f62e8c71d diff --git a/t/test.pm b/t/test.pm index 49ed95a..f72ae08 100644 --- a/t/test.pm +++ b/t/test.pm @@ -8,19 +8,6 @@ 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( evcheck runcheck ); - - BEGIN { - plan tests => 3, - todo => [], - ; - } - ok evcheck(sub { open my $fh, '>', 'foo'; print $fh "$_\n" @@ -28,10 +15,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,91 +67,19 @@ The following symbols are exported upon request: =item evcheck -=item save_output - -=item restore_output - -=item tmpnam - -=item tempdir - -=item find_exec - =back =cut -@EXPORT_OK = qw( evcheck save_output restore_output ); +@EXPORT_OK = qw( evcheck ); # Utility ----------------------------- -use Carp qw( carp croak ); -use Cwd 2.01 qw( cwd ); -use Env qw( PATH ); -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 File::Spec->catdir(cwd, $_[0]); - } -} - -sub min { - croak "Can't min over 0 args!\n" - unless @_; - my $min = $_[0]; - for (@_[1..$#_]) { - $min = $_ - if $_ < $min; - } - - return $min; -} - -# ------------------------------------- -# PACKAGE CONSTANTS -# ------------------------------------- - -use constant BUILD_SCRIPT_DIR => => File::Spec->catdir( $Bin, File::Spec->updir, qw( blib script ) ); - -sub find_exec { - my ($exec) = @_; - - for (split /:/, $PATH) { - my $try = File::Spec->catfile($_, $exec); - return rel2abs($try) - if -x $try; - } - return; -} - -# ------------------------------------- -# PACKAGE ACTIONS -# ------------------------------------- +use Carp qw( carp ); -$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 # ------------------------------------- @@ -226,297 +137,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; -} - -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 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 # ----------------------------------------------------------------------------