The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use Carp;

my $err_file = 't/errors';

END { unlink $err_file }


sub setup_stderr
{
   open (SAVE_STDERR, ">&STDERR")
      || die "couldn't save stderr: $!\n";
   open (STDERR, ">$err_file")
      || die "couldn't redirect stderr to $err_file: $!\n";
   STDERR->autoflush (1);

#   $SIG{'__WARN__'} = sub { print SAVE_STDERR @_ };
   $SIG{'__DIE__'} = sub
   {
      open (STDERR, '>&=' . fileno (SAVE_STDERR));
      die @_;
   };
}

sub warnings
{
   my @err;
   open (ERR, $err_file) || die "couldn't open $err_file: $!\n";
   chomp (@err = <ERR>);
   close (ERR);
   open (STDERR, ">$err_file")
      || die "couldn't redirect stderr to $err_file: $!\n";
   STDERR->autoflush (1);
   if ($DEBUG)
   {
      printf "caught %d messages on stderr:\n", scalar @err;
      print join ("\n", @err) . "\n";
   }
   @err;
}

sub list_equal
{
   my ($eq, $a, $b) = @_;

   croak "list_equal: \$a and \$b not lists" 
      unless ref $a eq 'ARRAY' && ref $b eq 'ARRAY';

   return 0 unless @$a == @$b;          # compare lengths
   my @eq = map { &$eq ($a->[$_], $b->[$_]) } (0 .. $#$a);
   return 0 unless (grep ($_ == 1, @eq)) == @eq;
}

sub slist_equal
{
   my ($a, $b) = @_;
   list_equal (sub
               {
                  my ($a, $b) = @_;
                  (defined $a && defined $b && $a eq $b) ||
                     (! defined $a && ! defined $b);
               }, $a, $b);
}

my $i = 1;
sub test
{
   my ($result) = @_;

   ++$i;
   printf "%s %d\n", ($result ? "ok" : "not ok"), $i;
}

sub test_entry
{
   my ($entry, $type, $key, $fields, $values) = @_;
   my ($i, @vals);

   croak "test_entry: num fields != num values"
      unless $#$fields == $#$values;
   test ($entry->parse_ok);
   test ($entry->type eq $type);
   test (defined $key ? $entry->key eq $key : !defined $entry->key);
   test (slist_equal ([$entry->fieldlist], $fields));
   for $i (0 .. $#$fields)
   {
      my $val = $entry->get ($fields->[$i]) || '';
      test ($entry->exists ($fields->[$i]) &&
            $val eq $values->[$i]);
   }

   @vals = map ($_ || '', $entry->get (@$fields));
   test (slist_equal (\@vals, $values));
}

1;