Acme-EyeDrops

 view release on metacpan or  search on metacpan

t/19_surrounds.t  view on Meta::CPAN

#    sub PRINT { my $self = shift; $knob .= join('', @_) }
#    sub PRINTF {
#       my $self = shift; my $fmt = shift;
#       $knob .= sprintf($fmt, @_);
#    }
#    package main;
#    tie *STDOUT, 'MyStdout';
# See, for example, TieOut.pm in the t/lib directory of ExtUtils-MakeMaker.
# (TieOut.pm is a little invention of chromatic's).

my $outf = 'out.tmp';
my $errf = 'err.tmp';
-f $outf and (unlink($outf) or die "error: unlink '$outf': $!");
-f $errf and (unlink($errf) or die "error: unlink '$errf': $!");

my $itest = 0;

sub test_one {
   my ($e, $rtests) = @_;

   local *SAVERR; open(SAVERR, ">&STDERR");  # save original STDERR
   local *SAVOUT; open(SAVOUT, ">&STDOUT");  # save original STDOUT
   open(STDOUT, '>'.$outf) or die "Could not create '$outf': $!";
   open(STDERR, '>'.$errf) or die "Could not create '$errf': $!";
   my $status = Test::Harness::runtests(@{$rtests});
   # XXX: Test harness does not like the next two closes.
   # close(STDOUT) or die "error: close STDOUT: $!";
   # close(STDERR) or die "error: close STDERR: $!";
   open(STDERR, ">&SAVERR") or die "error: restore STDERR: $!";
   open(STDOUT, ">&SAVOUT") or die "error: restore STDOUT: $!";
   # XXX: is this necessary to prevent leaks?
   close(SAVOUT) or die "error: close SAVOUT: $!";
   close(SAVERR) or die "error: close SAVERR: $!";

   my $outstr = Acme::EyeDrops::_slurp_tfile($outf);
   my $errstr = Acme::EyeDrops::_slurp_tfile($errf);

   print STDERR "\nstdout of TestHarness::runtests:\n$outstr\n";
   print STDERR "stderr of TestHarness::runtests:\n$errstr\n";

   $status or print "not ";
   ++$itest; print "ok $itest - TestHarness::runtests of $e\n";
}

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

t/19_surrounds.t  view on Meta::CPAN

   test_one('sightly EyeDrops.pm, plain tests', \@tests);
   test_one('sightly EyeDrops.pm, generated tests', \@ztests);
}

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

for my $t (@ztests) { unlink($t) or die "error: unlink '$t': $!" }

rm_f_dir($genbase);

unlink($outf) or die "error: unlink '$outf': $!";
unlink($errf) or die "error: unlink '$errf': $!";



( run in 0.256 second using v1.01-cache-2.11-cpan-4d50c553e7e )