1#!/usr/bin/perl -w
2
3BEGIN {
4    unshift @INC, 't/lib';
5}
6
7# test T::H::_open_spool and _close_spool - these are good examples
8# of the 'Fragile Test' pattern - messing with I/O primitives breaks
9# nearly everything
10
11use strict;
12use warnings;
13use Test::More;
14
15my $useOrigOpen;
16my $useOrigClose;
17
18# setup replacements for core open and close - breaking these makes everything very fragile
19BEGIN {
20    $useOrigOpen = $useOrigClose = 1;
21
22    # taken from http://www.perl.com/pub/a/2002/06/11/threads.html?page=2
23
24    *CORE::GLOBAL::open = \&my_open;
25
26    sub my_open (*@) {
27        if ($useOrigOpen) {
28            if ( defined( $_[0] ) ) {
29                use Symbol qw();
30                my $handle = Symbol::qualify( $_[0], (caller)[0] );
31                no strict 'refs';
32                if ( @_ == 1 ) {
33                    return CORE::open($handle);
34                }
35                elsif ( @_ == 2 ) {
36                    return CORE::open( $handle, $_[1] );
37                }
38                else {
39                    die "Can't open with more than two args";
40                }
41            }
42        }
43        else {
44            return;
45        }
46    }
47
48    *CORE::GLOBAL::close = sub (*) {
49        if   ($useOrigClose) { return CORE::close(shift) }
50        else                 {return}
51    };
52
53}
54
55use TAP::Harness;
56use TAP::Parser;
57use TAP::Parser::Iterator::Array;
58
59plan tests => 4;
60
61{
62
63    # coverage tests for the basically untested T::H::_open_spool
64
65    my @spool = ( 't', 'spool' );
66    $ENV{PERL_TEST_HARNESS_DUMP_TAP} = File::Spec->catfile(@spool);
67
68# now given that we're going to be writing stuff to the file system, make sure we have
69# a cleanup hook
70
71    END {
72        use File::Path;
73
74        $useOrigOpen = $useOrigClose = 1;
75
76        # remove the tree if we made it this far
77        rmtree( $ENV{PERL_TEST_HARNESS_DUMP_TAP} )
78          if $ENV{PERL_TEST_HARNESS_DUMP_TAP};
79    }
80
81    my @die;
82
83    eval {
84        local $SIG{__DIE__} = sub { push @die, @_ };
85
86        # use the broken open
87        $useOrigOpen = 0;
88
89        TAP::Harness->_open_spool(
90            File::Spec->catfile(qw (source_tests harness )) );
91
92        # restore universal sanity
93        $useOrigOpen = 1;
94    };
95
96    is @die, 1, 'open failed, die as expected';
97
98    my $spoolDir = quotemeta(
99        File::Spec->catfile( @spool, qw( source_tests harness ) ) );
100
101    like pop @die, qr/ Can't write $spoolDir \( /, '...with expected message';
102
103    # now make close fail
104
105    use Symbol;
106
107    my $spoolHandle = gensym;
108
109    my $tap = <<'END_TAP';
1101..1
111ok 1 - input file opened
112
113END_TAP
114
115    my $parser = TAP::Parser->new(
116        {   spool => $spoolHandle,
117            iterator =>
118              TAP::Parser::Iterator::Array->new( [ split /\n/ => $tap ] )
119        }
120    );
121
122    @die = ();
123
124    eval {
125        local $SIG{__DIE__} = sub { push @die, @_ };
126
127        # use the broken CORE::close
128        $useOrigClose = 0;
129
130        TAP::Harness->_close_spool($parser);
131
132        $useOrigClose = 1;
133    };
134
135    unless ( is @die, 1, 'close failed, die as expected' ) {
136        diag " >>> $_ <<<\n" for @die;
137    }
138
139    like pop @die, qr/ Error closing TAP spool file[(] /,
140      '...with expected message';
141}
142