X-Git-Url: https://git.donarmstrong.com/?p=term-progressbar.git;a=blobdiff_plain;f=t%2Ftest.pm;h=c10aa57dff118abb548fec603c304c81d4e920d9;hp=482ae7630ab871e7edba69cfdaf927e2e7576d75;hb=c117fc5047ab77ee6df1d6a7c6a595a3ebc87d00;hpb=b77f6c08d275107e56e74e80e440c8a6b4161389 diff --git a/t/test.pm b/t/test.pm index 482ae76..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 @@ -82,32 +78,13 @@ The following symbols are exported upon request: =over 4 -=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( check_req compare evcheck find_exec only_files read_file - save_output restore_output tempdir tmpnam ); +@EXPORT_OK = qw( evcheck ); # Utility ----------------------------- @@ -117,63 +94,20 @@ 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 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 ); # ---------------------------------------------------------------------------- -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; -} - # ------------------------------------- # PACKAGE CONSTANTS # ------------------------------------- -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 BUILD_SCRIPT_DIR => => File::Spec->catdir( $Bin, File::Spec->updir, qw( blib script ) ); # ------------------------------------- # PACKAGE ACTIONS @@ -181,86 +115,12 @@ sub find_exec { $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 @@ -314,803 +174,8 @@ 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 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