=over 4
-=item check_req
-
-=item compare
-
=item evcheck
-=item only_files
-
=item save_output
=item restore_output
=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 save_output restore_output );
# Utility -----------------------------
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 );
# ----------------------------------------------------------------------------
-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
$PATH = join ':', BUILD_SCRIPT_DIR, split /:/, $PATH;
-$_ = rel2abs($_)
- for @INC;
-
my $tmpdn = tempdir();
$| = 1;
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
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
}
}
-# -------------------------------------
-
-=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<Mandatory> File to compare
-
-=item fn2
-
-B<Mandatory> File to compare
-
-=item name
-
-B<Mandatory> Test name
-
-=item sort
-
-B<Optional> sort files prior to comparison. Requires the C<sort> command to
-be on C<$PATH> (else skips).
-
-=item gunzip
-
-B<Optional> gunzip files prior to comparison. Requires the C<gzip> command to
-be on C<$PATH> (else skips). gzip occurs prior to any sort.
-
-=item untar
-
-B<Optional> untar files prior to comparison. Requires the C<tar> 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 = <OUT>;
-#XYZ my $err = <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<make>
-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<epres|"epres">.
-
-=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<Mandatory>
-
-=item line-terminator
-
-B<Optional>. 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
projects / term-progressbar.git / blobdiff