summaryrefslogtreecommitdiff
path: root/ext/Test-Harness/t/spool.t
diff options
context:
space:
mode:
Diffstat (limited to 'ext/Test-Harness/t/spool.t')
-rw-r--r--ext/Test-Harness/t/spool.t139
1 files changed, 0 insertions, 139 deletions
diff --git a/ext/Test-Harness/t/spool.t b/ext/Test-Harness/t/spool.t
deleted file mode 100644
index d22ffcdd77..0000000000
--- a/ext/Test-Harness/t/spool.t
+++ /dev/null
@@ -1,139 +0,0 @@
-#!/usr/bin/perl -w
-
-BEGIN {
- unshift @INC, 't/lib';
-}
-
-# test T::H::_open_spool and _close_spool - these are good examples
-# of the 'Fragile Test' pattern - messing with I/O primitives breaks
-# nearly everything
-
-use strict;
-use Test::More;
-
-my $useOrigOpen;
-my $useOrigClose;
-
-# setup replacements for core open and close - breaking these makes everything very fragile
-BEGIN {
- $useOrigOpen = $useOrigClose = 1;
-
- # taken from http://www.perl.com/pub/a/2002/06/11/threads.html?page=2
-
- *CORE::GLOBAL::open = \&my_open;
-
- sub my_open (*@) {
- if ($useOrigOpen) {
- if ( defined( $_[0] ) ) {
- use Symbol qw();
- my $handle = Symbol::qualify( $_[0], (caller)[0] );
- no strict 'refs';
- if ( @_ == 1 ) {
- return CORE::open($handle);
- }
- elsif ( @_ == 2 ) {
- return CORE::open( $handle, $_[1] );
- }
- else {
- die "Can't open with more than two args";
- }
- }
- }
- else {
- return;
- }
- }
-
- *CORE::GLOBAL::close = sub (*) {
- if ($useOrigClose) { return CORE::close(shift) }
- else {return}
- };
-
-}
-
-use TAP::Harness;
-use TAP::Parser;
-
-plan tests => 4;
-
-{
-
- # coverage tests for the basically untested T::H::_open_spool
-
- my @spool = ( 't', 'spool' );
- $ENV{PERL_TEST_HARNESS_DUMP_TAP} = File::Spec->catfile(@spool);
-
-# now given that we're going to be writing stuff to the file system, make sure we have
-# a cleanup hook
-
- END {
- use File::Path;
-
- $useOrigOpen = $useOrigClose = 1;
-
- # remove the tree if we made it this far
- rmtree( $ENV{PERL_TEST_HARNESS_DUMP_TAP} )
- if $ENV{PERL_TEST_HARNESS_DUMP_TAP};
- }
-
- my @die;
-
- eval {
- local $SIG{__DIE__} = sub { push @die, @_ };
-
- # use the broken open
- $useOrigOpen = 0;
-
- TAP::Harness->_open_spool(
- File::Spec->catfile(qw (source_tests harness )) );
-
- # restore universal sanity
- $useOrigOpen = 1;
- };
-
- is @die, 1, 'open failed, die as expected';
-
- my $spoolDir = quotemeta(
- File::Spec->catfile( @spool, qw( source_tests harness ) ) );
-
- like pop @die, qr/ Can't write $spoolDir \( /, '...with expected message';
-
- # now make close fail
-
- use Symbol;
-
- my $spoolHandle = gensym;
-
- my $tap = <<'END_TAP';
-1..1
-ok 1 - input file opened
-
-END_TAP
-
- my $parser = TAP::Parser->new(
- { spool => $spoolHandle,
- stream =>
- TAP::Parser::IteratorFactory->new( [ split /\n/ => $tap ] )
- }
- );
-
- @die = ();
-
- eval {
- local $SIG{__DIE__} = sub { push @die, @_ };
-
- # use the broken CORE::close
- $useOrigClose = 0;
-
- TAP::Harness->_close_spool($parser);
-
- $useOrigClose = 1;
- };
-
- unless ( is @die, 1, 'close failed, die as expected' ) {
- diag " >>> $_ <<<\n" for @die;
- }
-
- like pop @die, qr/ Error closing TAP spool file[(] /,
- '...with expected message';
-}