Gecko [ www.blackthorn-inc.com ]

Name	Size	Permission	Date
compat	[ DIR ]	drwxr-xr-x	2015-02-14 16:55
data	[ DIR ]	drwxr-xr-x	2015-02-14 16:55
lib	[ DIR ]	drwxr-xr-x	2015-02-14 16:55
proverc	[ DIR ]	drwxr-xr-x	2015-02-14 16:55
sample-tests	[ DIR ]	drwxr-xr-x	2015-02-14 16:55
source_tests	[ DIR ]	drwxr-xr-x	2016-10-10 18:24
subclass_tests	[ DIR ]	drwxr-xr-x	2015-02-14 16:55
aggregator.t	9.35 KB	-r--r--r--	2014-12-27 11:48
bailout.t	3.12 KB	-r--r--r--	2014-12-27 11:48
base.t	4.68 KB	-r--r--r--	2014-12-27 11:48
callbacks.t	2.57 KB	-r--r--r--	2014-12-27 11:48
console.t	1.06 KB	-r--r--r--	2014-12-27 11:48
errors.t	4.64 KB	-r--r--r--	2014-12-27 11:48
file.t	13.61 KB	-r--r--r--	2014-12-27 11:48
glob-to-regexp.t	988 B	-r--r--r--	2014-12-27 11:48
grammar.t	11.55 KB	-r--r--r--	2014-12-27 11:48
harness-bailout.t	1.19 KB	-r--r--r--	2014-12-27 11:48
harness-subclass.t	1.58 KB	-r--r--r--	2014-12-27 11:48
harness.t	28.38 KB	-r--r--r--	2014-12-27 11:48
iterator_factory.t	4.8 KB	-r--r--r--	2014-12-27 11:48
iterators.t	5.68 KB	-r--r--r--	2014-12-27 11:48
multiplexer.t	4.53 KB	-r--r--r--	2014-12-27 11:48
nested.t	860 B	-r--r--r--	2014-12-27 11:48
nofork-mux.t	119 B	-r--r--r--	2014-12-27 11:48
nofork.t	1.55 KB	-r--r--r--	2014-12-27 11:48
object.t	772 B	-r--r--r--	2014-12-27 11:48
parse.t	30.97 KB	-r--r--r--	2014-12-27 11:48
parser-config.t	731 B	-r--r--r--	2014-12-27 11:48
parser-subclass.t	2.2 KB	-r--r--r--	2014-12-27 11:48
perl5lib.t	1.13 KB	-r--r--r--	2014-12-27 11:48
premature-bailout.t	2.32 KB	-r--r--r--	2014-12-27 11:48
process.t	1015 B	-r--r--r--	2014-12-27 11:48
prove.t	47.6 KB	-r--r--r--	2014-12-27 11:49
proveenv.t	338 B	-r--r--r--	2014-12-27 11:49
proverc.t	472 B	-r--r--r--	2014-12-27 11:48
proverun.t	4.14 KB	-r--r--r--	2014-12-27 11:48
proveversion.t	763 B	-r--r--r--	2014-12-27 11:48
regression.t	111.62 KB	-r--r--r--	2014-12-27 11:48
results.t	7.68 KB	-r--r--r--	2014-12-27 11:48
scheduler.t	5.33 KB	-r--r--r--	2014-12-27 11:48
source.t	8.21 KB	-r--r--r--	2014-12-27 11:48
source_handler.t	12.32 KB	-r--r--r--	2014-12-27 11:48
spool.t	3.12 KB	-r--r--r--	2014-12-27 11:48
state.t	7.7 KB	-r--r--r--	2014-12-27 11:48
state_results.t	4.95 KB	-r--r--r--	2014-12-27 11:48
streams.t	6.33 KB	-r--r--r--	2014-12-27 11:48
taint.t	1.3 KB	-r--r--r--	2014-12-27 11:49
testargs.t	4.95 KB	-r--r--r--	2014-12-27 11:48
unicode.t	3.73 KB	-r--r--r--	2014-12-27 11:48
yamlish-output.t	2.44 KB	-r--r--r--	2014-12-27 11:48
yamlish-writer.t	7.17 KB	-r--r--r--	2014-12-27 11:48
yamlish.t	15.01 KB	-r--r--r--	2014-12-27 11:48

Rename

#!/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 warnings;
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;
use TAP::Parser::Iterator::Array;

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,
            iterator =>
              TAP::Parser::Iterator::Array->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';
}