# (X)Emacs mode: -*- cperl -*-

package test;

=head1 NAME

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( DATA_DIR
                                evcheck runcheck );

  BEGIN {
    plan tests  => 3,
         todo   => [],
         ;
  }

  ok evcheck(sub {
               open my $fh, '>', 'foo';
               print $fh "$_\n"
                 for 'Bulgaria', 'Cholet';
               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
scripts, such as those used in F<t/>.

This package does not including running external programs; that is provided by
C<test2.pm>.  This is so that suites not needing that can include only
test.pm, and so not require the presence of C<IPC::Run>.

Setting up the environment includes:

=over 4

=item Prepending F<blib/script> onto the path

=item Pushing the module F<lib/> dir onto the @PERL5LIB var

For executed scripts.

=item Pushing the module F<lib/> dir onto the @INC var

For internal C<use> calls.

=item Changing directory to a temporary directory

To avoid cluttering the local dir, and/or allowing the local directory
structure to affect matters.

=item Cleaning up the temporary directory afterwards

Unless TEST_DEBUG is set in the environment.

=back

=cut

# ----------------------------------------------------------------------------

# Pragmas -----------------------------

use 5.00503;
use strict;
use vars qw( @EXPORT_OK );

# Inheritance -------------------------

use base qw( Exporter );

=head2 EXPORTS

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

=item tmpnam

=item tempdir

=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 );

# Utility -----------------------------

use Carp                          qw( carp croak );
use Cwd                      2.01 qw( cwd );
use Env                           qw( PATH PERL5LIB );
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 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;
}

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 );

sub find_exec {
  my ($exec) = @_;

  for (split /:/, $PATH) {
    my $try = 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($_)
  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

=over 4

=item ARGUMENTS

=over 4

=item code

Coderef to eval

=item name

Name to use in error messages

=back

=item RETURNS

=over 4

=item okay

1 if eval was okay, 0 if not.

=back

=back

=cut

sub evcheck {
  my ($code, $name) = @_;

  my $ok = 0;

  eval {
    &$code;
    $ok = 1;
  }; if ( $@ ) {
    carp "Code $name failed: $@\n"
      if $ENV{TEST_DEBUG};
    $ok = 0;
  }

  return $ok;
}

# -------------------------------------

=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<restore_output>)

=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<save_output>).

=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<POSIX> or L<File::Temp>, but does not get deleted
if TEST_DEBUG has SAVE in the value.

=over 4

=item ARGUMENTS

=over 4

=item name

I<Optional>.  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<POSIX> or L<File::Temp>, but does not get deleted
if TEST_DEBUG has SAVE in the value (does get deleted otherwise).

=over 4

=item ARGUMENTS

I<None>

=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<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

Z<>

=head1 BUGS

Z<>

=head1 REPORTING BUGS

Email the author.

=head1 AUTHOR

Martyn J. Pearce C<fluffy@cpan.org>

=head1 COPYRIGHT

Copyright (c) 2001, 2002, 2004 Martyn J. Pearce.  This program is free
software; you can redistribute it and/or modify it under the same terms as
Perl itself.

=head1 SEE ALSO

Z<>

=cut

1; # keep require happy.

__END__