X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=t%2Ftest.pm;h=1a7422945c06df796a1ee8959812b6d33146796f;hb=aa6d2faf4a09834c6d5d5c3cda646697aa346912;hp=59c25cbfc52d1b6a816b78c7fe6e39b3c35cf916;hpb=3797cda1b0da9caa24c7ff35e910e1f318c77918;p=term-progressbar.git diff --git a/t/test.pm b/t/test.pm index 59c25cb..1a74229 100644 --- a/t/test.pm +++ b/t/test.pm @@ -13,8 +13,7 @@ test - tools for helping in test suites (not including running externalprograms) BEGIN { unshift @INC, $Bin }; - use test qw( DATA_DIR - evcheck runcheck ); + use test qw( evcheck runcheck ); BEGIN { plan tests => 3, @@ -48,10 +47,6 @@ Setting up the environment includes: =item Prepending F onto the path -=item Pushing the module F dir onto the @PERL5LIB var - -For executed scripts. - =item Pushing the module F dir onto the @INC var For internal C calls. @@ -87,24 +82,10 @@ The following symbols are exported upon request: =over 4 -=item BIN_DIR - -=item DATA_DIR - -=item REF_DIR - -=item LIB_DIR - -=item PERL - -=item check_req - =item compare =item evcheck -=item only_files - =item save_output =item restore_output @@ -115,21 +96,17 @@ The following symbols are exported upon request: =item find_exec -=item read_file - =back =cut -@EXPORT_OK = qw( BIN_DIR DATA_DIR REF_DIR LIB_DIR PERL - check_req compare evcheck find_exec only_files read_file - save_output restore_output tempdir tmpnam ); +@EXPORT_OK = qw( evcheck save_output restore_output ); # Utility ----------------------------- use Carp qw( carp croak ); use Cwd 2.01 qw( cwd ); -use Env qw( PATH PERL5LIB ); +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 ); @@ -146,22 +123,10 @@ sub rel2abs { if ( File::Spec->file_name_is_absolute($_[0]) ) { return $_[0]; } else { - return catdir(cwd, $_[0]); + return File::Spec->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 @_; @@ -174,53 +139,27 @@ sub min { return $min; } -sub max { - croak "Can't max over 0 args!\n" - unless @_; - my $max = $_[0]; - for (@_[1..$#_]) { - $max = $_ - if $_ > $max; - } - - return $max; -} - # ------------------------------------- # PACKAGE CONSTANTS # ------------------------------------- -use constant BIN_DIR => catdir $Bin, updir, 'bin'; -use constant DATA_DIR => catdir $Bin, updir, 'data'; -use constant REF_DIR => catdir $Bin, updir, 'testref'; -use constant LIB_DIR => catdir $Bin, updir, 'lib'; - -use constant BUILD_SCRIPT_DIR => => catdir $Bin, updir, qw( blib script ); +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 = catfile $_, $exec; + my $try = File::Spec->catfile($_, $exec); return rel2abs($try) if -x $try; } return; } -use constant PERL => (basename($^X) eq $^X ? - find_exec($^X) : - rel2abs($^X)); - # ------------------------------------- # PACKAGE ACTIONS # ------------------------------------- -# @PERL5LIB not available in Env for perl 5.00503 -# unshift @PERL5LIB, LIB_DIR; -$PERL5LIB = defined $PERL5LIB ? join(':', LIB_DIR, $PERL5LIB) : LIB_DIR; -unshift @INC, LIB_DIR; - $PATH = join ':', BUILD_SCRIPT_DIR, split /:/, $PATH; $_ = rel2abs($_) @@ -240,69 +179,6 @@ 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 @@ -670,43 +546,6 @@ is equal. If the sort flag is present, each file is sorted prior to comparison. =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__}; @@ -958,120 +797,6 @@ END # ------------------------------------- -=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 @@ -1103,56 +828,6 @@ nothing, if no such file exists. # 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